diff options
Diffstat (limited to 'ghc/compiler/deforest/Cyclic.lhs')
| -rw-r--r-- | ghc/compiler/deforest/Cyclic.lhs | 411 |
1 files changed, 411 insertions, 0 deletions
diff --git a/ghc/compiler/deforest/Cyclic.lhs b/ghc/compiler/deforest/Cyclic.lhs new file mode 100644 index 0000000000..318921ccec --- /dev/null +++ b/ghc/compiler/deforest/Cyclic.lhs @@ -0,0 +1,411 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Cyclic]{Knot tying} + +>#include "HsVersions.h" +> +> module Cyclic ( +> mkLoops, fixupFreeVars +> ) where + +> import DefSyn +> import PlainCore +> import DefUtils +> import Def2Core ( d2c, defPanic ) +>#ifdef __HBC__ +> import Trace +>#endif + +> import AbsUniType ( glueTyArgs, quantifyTy, mkForallTy, mkTyVarTy, +> TyVarTemplate +> ) +> import Digraph ( dfs ) +> import Id ( getIdUniType, toplevelishId, updateIdType, +> getIdInfo, replaceIdInfo, eqId, Id +> ) +> import IdInfo +> import Maybes ( Maybe(..) ) +> import Outputable +> import Pretty +> import SplitUniq +> import Util + +----------------------------------------------------------------------------- +A more efficient representation for lists that are extended multiple +times, but only examined once. + +> type FList a = [a] -> [a] +> append = (.) +> singleton x = (x:) +> cons x xs = \ys -> x:(xs ys) +> list x = (x++) +> emptylist = id + +----------------------------------------------------------------------------- +Monad for the knot-tier. + +> type Lbl a = SUniqSM ( +> [(Id)], -- loops used +> [(Id,DefExpr,[Id],DefExpr)], -- bindings floating upwards +> [(Id,DefExpr)], -- back loops +> a) -- computation result +> +> thenLbl :: Lbl a -> (a -> Lbl b) -> Lbl b +> thenLbl a k +> = a `thenSUs` \(ls, bs, bls, a) -> +> k a `thenSUs` \(ls',bs',bls', b) -> +> returnSUs (ls ++ ls', bs ++ bs', bls ++ bls', b) +> +> returnLbl :: a -> Lbl a +> returnLbl a = returnSUs ([],[],[],a) +> +> mapLbl :: (a -> Lbl b) -> [a] -> Lbl [b] +> mapLbl f [] = returnLbl [] +> mapLbl f (x:xs) +> = f x `thenLbl` \x -> +> mapLbl f xs `thenLbl` \xs -> +> returnLbl (x:xs) + +----------------------------------------------------------------------------- + +This is terribly inefficient. + +> mkLoops :: DefExpr -> SUniqSM ([(Id,DefExpr)],DefExpr) +> mkLoops e = +> error "mkLoops" +>{- LATER: +> loop [] e `thenSUs` \(ls,bs,bls,e) -> + +Throw away all the extracted bindings that can't be reached. These +can occur as the result of some forward loops being short-circuited by +back-loops. We find out which bindings can be reached by a +depth-first search of the call graph starting with the free variables +of the expression being returned. + +> let +> loops_out = filter deforestable (freeVars e) +> (_,reachable) = dfs (==) r ([],[]) loops_out +> r f = lookup f bs +> +> lookup f [] = [] +> lookup f ((g,out,_):xs) | f == g = out +> | otherwise = lookup f xs +> +> isReachable (f,_,_) = f `elem` reachable +> in +> returnSUs (map (\(f,_,e) -> (f,e)) (filter isReachable bs),e) +> where + +> loop :: [(Id,DefExpr,[Id],[TyVar])] -> DefExpr -> Lbl DefExpr + +> loop ls (CoVar (Label e e1)) +> = +> d2c e `thenSUs` \core_e -> +>-- trace ("loop:\n" ++ ppShow 80 (ppr PprDebug core_e)) $ + +> mapSUs (\(f,e',val_args,ty_args) -> +> renameExprs e' e `thenSUs` \r -> +> returnSUs (f,val_args,ty_args,r)) ls `thenSUs` \results -> +> let +> loops = +> [ (f,val_args,ty_args,r) | +> (f,val_args,ty_args,IsRenaming r) <- results ] +> inconsistent_renamings = +> [ (f,r) | +> (f,val_args,ty_args,InconsistentRenaming r) +> <- results ] +> in +> +> (case loops of +> [] -> + +Ok, there are no loops (i.e. this expression hasn't occurred before). +Prepare for a possible re-occurrence of *this* expression, by making +up a new function name and type (laziness ensures that this isn't +actually done unless the function is required). + +The type of a new function, if one is generated at this point, is +constructed as follows: + + \/ a1 ... \/ an . b1 -> ... -> bn -> t + +where a1...an are the free type variables in the expression, b1...bn +are the types of the free variables in the expression, and t is the +type of the expression itself. + +> let +> +> -- Collect the value/type arguments for the function +> fvs = freeVars e +> val_args = filter isArgId fvs +> ty_args = freeTyVars e +> +> -- Now to make up the type... +> base_type = typeOfCoreExpr core_e +> fun_type = glueTyArgs (map getIdUniType val_args) base_type +> (_, type_of_f) = quantifyTy ty_args fun_type +> in +> +> newDefId type_of_f `thenSUs` \f' -> +> let +> f = replaceIdInfo f' +> (addInfo (getIdInfo f') DoDeforest) +> in +> loop ((f,e,val_args,ty_args):ls) e1 +> `thenSUs` \res@(ls',bs,bls,e') -> + +Key: ls = loops, bs = bindings, bls = back loops, e = expression. + +If we are in a back-loop (i.e. we found a label somewhere below which +this expression is a renaming of), then just insert the expression +here. + +Comment the next section out to disable back-loops. + +(NB. I've seen this panic too - investigate?) + +> let back_loops = reverse [ e | (f',e) <- bls, f' == f ] in +> if not (null back_loops){- && not (f `elem` ls')-} then +> --if length back_loops > 1 then panic "barf!" else +> d2c (head back_loops) `thenSUs` \core_e -> +> trace ("Back Loop:\n" ++ +> ppShow 80 (ppr PprDebug core_e)) $ + +If we find a back-loop that also occurs where we would normally make a +new function... + +> if f `elem` ls' then +> d2c e' `thenSUs` \core_e' -> +> trace ("In Forward Loop " ++ +> ppShow 80 (ppr PprDebug f) ++ "\n" ++ +> ppShow 80 (ppr PprDebug core_e')) $ +> if f `notElem` (freeVars (head back_loops)) then +> returnSUs (ls', bs, bls, head back_loops) +> else +> panic "hello" +> else + +> returnSUs (ls', bs, bls, head back_loops) +> else + +If we are in a forward-loop (i.e. we found a label somewhere below +which is a renaming of this one), then make a new function definition. + +> if f `elem` ls' then +> +> rebindExpr (mkCoTyLam ty_args (mkCoLam val_args e')) +> `thenSUs` \rhs -> +> returnSUs +> (ls', +> (f,filter deforestable (freeVars e'),e,rhs) : bs, +> bls, +> mkLoopFunApp val_args ty_args f) + +otherwise, forget about it + +> else returnSUs res + +This is a loop, just make a call to the function which we +will create on the way back up the tree. + +(NB: it appears that sometimes we do get more than one loop matching, +investigate this?) + +> ((f,val_args,ty_args,r):_) -> +> +> returnSUs +> ([f], -- found a loop, propagate it back +> [], -- no bindings +> [], -- no back loops +> mkLoopFunApp (applyRenaming r val_args) ty_args f) +> +> ) `thenSUs` \res@(ls',bs,bls,e') -> + +If this expression reoccurs, record the binding and replace the cycle +with a call to the new function. We also rebind all the free +variables in the new function to avoid name clashes later. + +> let +> findBackLoops (g,r) bls +> | consistent r' = subst s e' `thenSUs` \e' -> +> returnSUs ((g,e') : bls) +> | otherwise = returnSUs bls +> where +> r' = map swap r +> s = map (\(x,y) -> (x, CoVar (DefArgVar y))) (nub r') +> in + +We just want the first one (ie. furthest up the tree), so reverse the +list of inconsistent renamings. + +> foldrSUs findBackLoops [] (reverse inconsistent_renamings) +> `thenSUs` \back_loops -> + +Comment out the next block to disable back-loops. ToDo: trace all of them. + +> if not (null back_loops) then +> d2c e' `thenSUs` \core_e -> +> trace ("Floating back loop:\n" +> ++ ppShow 80 (ppr PprDebug core_e)) +> returnSUs (ls', bs, back_loops ++ bls, e') +> else +> returnSUs res + +> loop ls e@(CoVar (DefArgVar v)) +> = returnLbl e +> loop ls e@(CoLit l) +> = returnLbl e +> loop ls (CoCon c ts es) +> = mapLbl (loopAtom ls) es `thenLbl` \es -> +> returnLbl (CoCon c ts es) +> loop ls (CoPrim op ts es) +> = mapLbl (loopAtom ls) es `thenLbl` \es -> +> returnLbl (CoPrim op ts es) +> loop ls (CoLam vs e) +> = loop ls e `thenLbl` \e -> +> returnLbl (CoLam vs e) +> loop ls (CoTyLam alpha e) +> = loop ls e `thenLbl` \e -> +> returnLbl (CoTyLam alpha e) +> loop ls (CoApp e v) +> = loop ls e `thenLbl` \e -> +> loopAtom ls v `thenLbl` \v -> +> returnLbl (CoApp e v) +> loop ls (CoTyApp e t) +> = loop ls e `thenLbl` \e -> +> returnLbl (CoTyApp e t) +> loop ls (CoCase e ps) +> = loop ls e `thenLbl` \e -> +> loopCaseAlts ls ps `thenLbl` \ps -> +> returnLbl (CoCase e ps) +> loop ls (CoLet (CoNonRec v e) e') +> = loop ls e `thenLbl` \e -> +> loop ls e' `thenLbl` \e' -> +> returnLbl (CoLet (CoNonRec v e) e') +> loop ls (CoLet (CoRec bs) e) +> = mapLbl loopRecBind bs `thenLbl` \bs -> +> loop ls e `thenLbl` \e -> +> returnLbl (CoLet (CoRec bs) e) +> where +> vs = map fst bs +> loopRecBind (v, e) +> = loop ls e `thenLbl` \e -> +> returnLbl (v, e) +> loop ls e +> = defPanic "Cyclic" "loop" e + +> loopAtom ls (CoVarAtom (DefArgExpr e)) +> = loop ls e `thenLbl` \e -> +> returnLbl (CoVarAtom (DefArgExpr e)) +> loopAtom ls (CoVarAtom e@(DefArgVar v)) +> = defPanic "Cyclic" "loopAtom" (CoVar e) +> loopAtom ls (CoVarAtom e@(Label _ _)) +> = defPanic "Cyclic" "loopAtom" (CoVar e) +> loopAtom ls e@(CoLitAtom l) +> = returnLbl e +> +> loopCaseAlts ls (CoAlgAlts as def) = +> mapLbl loopAlgAlt as `thenLbl` \as -> +> loopDefault ls def `thenLbl` \def -> +> returnLbl (CoAlgAlts as def) +> where +> loopAlgAlt (c, vs, e) = +> loop ls e `thenLbl` \e -> +> returnLbl (c, vs, e) + +> loopCaseAlts ls (CoPrimAlts as def) = +> mapLbl loopPrimAlt as `thenLbl` \as -> +> loopDefault ls def `thenLbl` \def -> +> returnLbl (CoPrimAlts as def) +> where +> loopPrimAlt (l, e) = +> loop ls e `thenLbl` \e -> +> returnLbl (l, e) + +> loopDefault ls CoNoDefault = +> returnLbl CoNoDefault +> loopDefault ls (CoBindDefault v e) = +> loop ls e `thenLbl` \e -> +> returnLbl (CoBindDefault v e) +> -} + +> mkVar v = CoVarAtom (DefArgExpr (CoVar (DefArgVar v))) + +----------------------------------------------------------------------------- +The next function is applied to all deforestable functions which are +placed in the environment. Given a list of free variables in the +recursive set of which the function is a member, this funciton +abstracts those variables, generates a new Id with the new type, and +returns a substitution element which can be applied to all other +expressions and function right hand sides that call this function. + + (freeVars e) \subseteq (freeVars l) + +> fixupFreeVars :: [Id] -> Id -> DefExpr -> ((Id,DefExpr),[(Id,DefExpr)]) +> fixupFreeVars total_fvs id e = +> case fvs of +> [] -> ((id,e),[]) +> _ -> let new_type = +> glueTyArgs (map getIdUniType fvs) +> (getIdUniType id) +> new_id = +> updateIdType id new_type +> in +> let +> t = foldl CoApp (CoVar (DefArgVar new_id)) +> (map mkVar fvs) +> in +> trace ("adding " ++ show (length fvs) ++ " args to " ++ ppShow 80 (ppr PprDebug id)) $ +> ((new_id, mkCoLam fvs e), [(id,t)]) +> where +> fvs = case e of +> CoLam bvs e -> filter (`notElem` bvs) total_fvs +> _ -> total_fvs + +> swap (x,y) = (y,x) + +> applyRenaming :: [(Id,Id)] -> [Id] -> [Id] +> applyRenaming r ids = map rename ids +> where +> rename x = case [ y | (x',y) <- r, x' `eqId` x ] of +> [] -> panic "Cyclic(rename): no match in rename" +> (y:_) -> y + +> mkLoopFunApp :: [Id] -> [TyVar] -> Id -> DefExpr +> mkLoopFunApp val_args ty_args f = +> foldl CoApp +> (foldl CoTyApp (CoVar (DefArgVar f)) +> (map mkTyVarTy ty_args)) +> (map mkVar val_args) + +----------------------------------------------------------------------------- +Removing duplicates from a list of definitions. + +> removeDuplicateDefinitions +> :: [(DefExpr,(Id,DefExpr))] -- (label,(id,rhs)) +> -> SUniqSM [(Id,DefExpr)] + +> removeDuplicateDefinitions defs = +> foldrSUs rem ([],[]) defs `thenSUs` \(newdefs,s) -> +> mapSUs (\(l,(f,e)) -> subst s e `thenSUs` \e -> +> returnSUs (f, e)) newdefs +> where + +> rem d@(l,(f,e)) (defs,s) = +> findDup l defs `thenSUs` \maybe -> +> case maybe of +> Nothing -> returnSUs (d:defs,s) +> Just g -> returnSUs (defs, (f,(CoVar.DefArgVar) g):s) + +We insist that labels rename in both directions, is this necessary? + +> findDup l [] = returnSUs Nothing +> findDup l ((l',(f,e)):defs) = +> renameExprs l l' `thenSUs` \r -> +> case r of +> IsRenaming _ -> renameExprs l' l `thenSUs` \r -> +> case r of +> IsRenaming r -> returnSUs (Just f) +> _ -> findDup l defs +> _ -> findDup l defs |