From ab9aa5ca58f83eb22ae60bce0f5c6480cc817593 Mon Sep 17 00:00:00 2001 From: simonm Date: Wed, 7 Jan 1998 16:03:08 +0000 Subject: [PATCH] [project @ 1998-01-07 16:03:03 by simonm] I was *sure* I'd removed these before... --- ghc/compiler/deforest/Core2Def.lhs | 142 ------- ghc/compiler/deforest/Cyclic.lhs | 404 -------------------- ghc/compiler/deforest/Def2Core.lhs | 156 -------- ghc/compiler/deforest/DefExpr.lhs | 659 -------------------------------- ghc/compiler/deforest/DefSyn.lhs | 59 --- ghc/compiler/deforest/DefUtils.lhs | 625 ------------------------------ ghc/compiler/deforest/Deforest.lhs | 138 ------- ghc/compiler/deforest/TreelessForm.lhs | 187 --------- 8 files changed, 2370 deletions(-) delete mode 100644 ghc/compiler/deforest/Core2Def.lhs delete mode 100644 ghc/compiler/deforest/Cyclic.lhs delete mode 100644 ghc/compiler/deforest/Def2Core.lhs delete mode 100644 ghc/compiler/deforest/DefExpr.lhs delete mode 100644 ghc/compiler/deforest/DefSyn.lhs delete mode 100644 ghc/compiler/deforest/DefUtils.lhs delete mode 100644 ghc/compiler/deforest/Deforest.lhs delete mode 100644 ghc/compiler/deforest/TreelessForm.lhs diff --git a/ghc/compiler/deforest/Core2Def.lhs b/ghc/compiler/deforest/Core2Def.lhs deleted file mode 100644 index 87d92be..0000000 --- a/ghc/compiler/deforest/Core2Def.lhs +++ /dev/null @@ -1,142 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 -% -\section[Core2Def]{Translate the CoreProgram into a DefProgram} - ->#include "HsVersions.h" -> -> module Core2Def ( -> core2def, c2d, -> -> DefProgram(..), -> GenCoreBinding, Id, DefBindee ) where -> -> import DefSyn - -> import CoreSyn -> import BinderInfo -- ( BinderInfo(..), isFun, isDupDanger ) -> import CmdLineOpts ( switchIsOn, SwitchResult, SimplifierSwitch ) -> import OccurAnal ( occurAnalyseBinds ) -> import SimplEnv ( SYN_IE(SwitchChecker) ) -> import Util -> import Pretty -> import Outputable - -This module translates the CoreProgram into a DefCoreProgram, -which includes non-atomic right-hand sides. The decisions about which -expressions to inline are left to the substitution analyser, which we -run beforehand. - -Current thinking: - -1. Inline all non-recursive non-top-level lets that occur only - once (including inside lambdas, hoping full laziness - will sort things out later). - -2. We don't inline top-level lets that occur only once, because these - might not be pulled out again by the let-floater, due to non- - garbage collection of CAFs. - -2.1. Also, what about these lit things that occur at the top level, - and are usually marked as macros? - -3. No recusrive functions are unfolded. - -ToDo: -4. Lambdas and case alternatives that bind a variable that occurs - multiple times are transformed: - \x -> ..x..x.. ===> \x -> let x' = x in ..x'..x'.. - - -> core2def :: (GlobalSwitch -> SwitchResult) -> [CoreBinding] -> DefProgram -> core2def sw prog = -> map coreBinding2def tagged_program -> where -> tagged_program = occurAnalyseBinds prog switch_is_on (const False) -> switch_is_on = switchIsOn sw - - -> coreBinding2def :: SimplifiableCoreBinding -> DefBinding -> coreBinding2def (NonRec (v,_) e) = NonRec v (c2d nullIdEnv e) -> coreBinding2def (Rec bs) = Rec (map recBind2def bs) -> where recBind2def ((v,_),e) = (v, c2d nullIdEnv e) - - -> coreAtom2def :: IdEnv DefExpr -> CoreArg -> DefAtom -> coreAtom2def p (VarArg v) = VarArg (DefArgExpr (lookup p v)) -> coreAtom2def p (LitArg l) = VarArg (DefArgExpr (Lit l)) - -> isTrivial (Con c [] []) = True -> isTrivial (Var v) = True -> isTrivial (Lit l) = True -> isTrivial _ = False - -> c2d :: IdEnv DefExpr -> SimplifiableCoreExpr -> DefExpr -> c2d p e = case e of -> -> Var v -> lookup p v -> -> Lit l -> Lit l -> -> Con c ts es -> Con c ts (map (coreAtom2def p) es) -> -> Prim op ts es -> Prim op ts (map (coreAtom2def p) es) -> -> Lam vs e -> Lam (map fst vs) (c2d p e) -> -> CoTyLam alpha e -> CoTyLam alpha (c2d p e) -> -> App e v -> App (c2d p e) (coreAtom2def p v) -> -> CoTyApp e t -> CoTyApp (c2d p e) t -> -> Case e ps -> Case (c2d p e) (coreCaseAlts2def p ps) -> -> Let (NonRec (v,ManyOcc _) e) e' -> | isTrivial e -> c2d (addOneToIdEnv p v (c2d p e)) e' -> | otherwise -> -> pprTrace "Not inlining ManyOcc " (ppr PprDebug v) $ -> Let (NonRec v (c2d p e)) (c2d p e') -> -> Let (NonRec (v,DeadCode) e) e' -> -> panic "Core2Def(c2d): oops, unexpected DeadCode" -> -> Let (NonRec (v,OneOcc fun_or_arg dup_danger _ _ _) e) e' -> | isTrivial e -> inline_it -> | isDupDanger dup_danger -> -> pprTrace "Not inlining DupDanger " (ppr PprDebug v) $ -> Let (NonRec v (c2d p e)) (c2d p e') -> | isFun fun_or_arg -> -> panic "Core2Def(c2d): oops, unexpected Macro" -> | otherwise -> inline_it -> where inline_it = c2d (addOneToIdEnv p v (c2d p e)) e' -> -> Let (Rec bs) e -> Let (Rec (map recBind2def bs)) (c2d p e) -> where recBind2def ((v,_),e) = (v, c2d p e) -> -> SCC l e -> SCC l (c2d p e) -> Coerce _ _ _ -> panic "Core2Def:Coerce" - - -> coreCaseAlts2def -> :: IdEnv DefExpr -> -> SimplifiableCoreCaseAlts -> -> DefCaseAlternatives -> -> coreCaseAlts2def p alts = case alts of -> AlgAlts as def -> AlgAlts (map algAlt2def as) (defAlt2def def) -> PrimAlts as def -> PrimAlts (map primAlt2def as) (defAlt2def def) -> -> where -> -> algAlt2def (c, vs, e) = (c, (map fst vs), c2d p e) -> primAlt2def (l, e) = (l, c2d p e) - -> defAlt2def NoDefault = NoDefault -> defAlt2def (BindDefault (v,_) e) = BindDefault v (c2d p e) - - -> lookup :: IdEnv DefExpr -> Id -> DefExpr -> lookup p v = case lookupIdEnv p v of -> Nothing -> Var (DefArgVar v) -> Just e -> e diff --git a/ghc/compiler/deforest/Cyclic.lhs b/ghc/compiler/deforest/Cyclic.lhs deleted file mode 100644 index 68a573c..0000000 --- a/ghc/compiler/deforest/Cyclic.lhs +++ /dev/null @@ -1,404 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 -% -\section[Cyclic]{Knot tying} - ->#include "HsVersions.h" -> -> module Cyclic ( -> mkLoops, fixupFreeVars -> ) where - -> import DefSyn -> import DefUtils -> import Def2Core ( d2c, defPanic ) - -> import Type ( glueTyArgs, quantifyTy, mkForallTy, mkTyVarTys, -> TyVarTemplate -> ) -> import Digraph ( dfs ) -> import Id ( idType, updateIdType, -> addIdDeforestInfo, eqId, Id -> ) -> import IdInfo -> import Outputable -> import Pretty -> import UniqSupply -> 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 = UniqSM ( -> [(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 `thenUs` \(ls, bs, bls, a) -> -> k a `thenUs` \(ls',bs',bls', b) -> -> returnUs (ls ++ ls', bs ++ bs', bls ++ bls', b) -> -> returnLbl :: a -> Lbl a -> returnLbl a = returnUs ([],[],[],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 -> UniqSM ([(Id,DefExpr)],DefExpr) -> mkLoops e = -> error "mkLoops" ->{- LATER: -> loop [] e `thenUs` \(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 -> returnUs (map (\(f,_,e) -> (f,e)) (filter isReachable bs),e) -> where - -> loop :: [(Id,DefExpr,[Id],[TyVar])] -> DefExpr -> Lbl DefExpr - -> loop ls (Var (Label e e1)) -> = -> d2c e `thenUs` \core_e -> ->-- trace ("loop:\n" ++ show (ppr PprDebug core_e)) $ - -> mapUs (\(f,e',val_args,ty_args) -> -> renameExprs e' e `thenUs` \r -> -> returnUs (f,val_args,ty_args,r)) ls `thenUs` \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 = coreExprType core_e -> fun_type = glueTyArgs (map idType val_args) base_type -> (_, type_of_f) = quantifyTy ty_args fun_type -> in -> -> newDefId type_of_f `thenUs` \f' -> -> let -> f = addIdDeforestInfo f' DoDeforest -> in -> loop ((f,e,val_args,ty_args):ls) e1 -> `thenUs` \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) `thenUs` \core_e -> -> pprTrace "Back Loop:\n" (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' `thenUs` \core_e' -> -> trace ("In Forward Loop " ++ -> show (ppr PprDebug f) ++ "\n" ++ -> show (ppr PprDebug core_e')) $ -> if f `notElem` (freeVars (head back_loops)) then -> returnUs (ls', bs, bls, head back_loops) -> else -> panic "hello" -> else - -> returnUs (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 (mkLam ty_args val_args e') -> `thenUs` \rhs -> -> returnUs -> (ls', -> (f,filter deforestable (freeVars e'),e,rhs) : bs, -> bls, -> mkLoopFunApp val_args ty_args f) - -otherwise, forget about it - -> else returnUs 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):_) -> -> -> returnUs -> ([f], -- found a loop, propagate it back -> [], -- no bindings -> [], -- no back loops -> mkLoopFunApp (applyRenaming r val_args) ty_args f) -> -> ) `thenUs` \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' `thenUs` \e' -> -> returnUs ((g,e') : bls) -> | otherwise = returnUs bls -> where -> r' = map swap r -> s = map (\(x,y) -> (x, Var (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) -> `thenUs` \back_loops -> - -Comment out the next block to disable back-loops. ToDo: trace all of them. - -> if not (null back_loops) then -> d2c e' `thenUs` \core_e -> -> trace ("Floating back loop:\n" -> ++ show (ppr PprDebug core_e)) -> returnUs (ls', bs, back_loops ++ bls, e') -> else -> returnUs res - -> loop ls e@(Var (DefArgVar v)) -> = returnLbl e -> loop ls e@(Lit l) -> = returnLbl e -> loop ls (Con c ts es) -> = mapLbl (loopAtom ls) es `thenLbl` \es -> -> returnLbl (Con c ts es) -> loop ls (Prim op ts es) -> = mapLbl (loopAtom ls) es `thenLbl` \es -> -> returnLbl (Prim op ts es) -> loop ls (Lam vs e) -> = loop ls e `thenLbl` \e -> -> returnLbl (Lam vs e) -> loop ls (CoTyLam alpha e) -> = loop ls e `thenLbl` \e -> -> returnLbl (CoTyLam alpha e) -> loop ls (App e v) -> = loop ls e `thenLbl` \e -> -> loopAtom ls v `thenLbl` \v -> -> returnLbl (App e v) -> loop ls (CoTyApp e t) -> = loop ls e `thenLbl` \e -> -> returnLbl (CoTyApp e t) -> loop ls (Case e ps) -> = loop ls e `thenLbl` \e -> -> loopCaseAlts ls ps `thenLbl` \ps -> -> returnLbl (Case e ps) -> loop ls (Let (NonRec v e) e') -> = loop ls e `thenLbl` \e -> -> loop ls e' `thenLbl` \e' -> -> returnLbl (Let (NonRec v e) e') -> loop ls (Let (Rec bs) e) -> = mapLbl loopRecBind bs `thenLbl` \bs -> -> loop ls e `thenLbl` \e -> -> returnLbl (Let (Rec 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 (VarArg (DefArgExpr e)) -> = loop ls e `thenLbl` \e -> -> returnLbl (VarArg (DefArgExpr e)) -> loopAtom ls (VarArg e@(DefArgVar v)) -> = defPanic "Cyclic" "loopAtom" (Var e) -> loopAtom ls (VarArg e@(Label _ _)) -> = defPanic "Cyclic" "loopAtom" (Var e) -> loopAtom ls e@(LitArg l) -> = returnLbl e -> -> loopCaseAlts ls (AlgAlts as def) = -> mapLbl loopAlgAlt as `thenLbl` \as -> -> loopDefault ls def `thenLbl` \def -> -> returnLbl (AlgAlts as def) -> where -> loopAlgAlt (c, vs, e) = -> loop ls e `thenLbl` \e -> -> returnLbl (c, vs, e) - -> loopCaseAlts ls (PrimAlts as def) = -> mapLbl loopPrimAlt as `thenLbl` \as -> -> loopDefault ls def `thenLbl` \def -> -> returnLbl (PrimAlts as def) -> where -> loopPrimAlt (l, e) = -> loop ls e `thenLbl` \e -> -> returnLbl (l, e) - -> loopDefault ls NoDefault = -> returnLbl NoDefault -> loopDefault ls (BindDefault v e) = -> loop ls e `thenLbl` \e -> -> returnLbl (BindDefault v e) -> -} - -> mkVar v = VarArg (DefArgExpr (Var (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 idType fvs) -> (idType id) -> new_id = -> updateIdType id new_type -> in -> let -> t = foldl App (Var (DefArgVar new_id)) -> (map mkVar fvs) -> in -> trace ("adding " ++ show (length fvs) ++ " args to " ++ show (ppr PprDebug id)) $ -> ((new_id, mkValLam fvs e), [(id,t)]) -> where -> fvs = case e of -> Lam 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 App -> (foldl CoTyApp (Var (DefArgVar f)) -> (mkTyVarTys ty_args)) -> (map mkVar val_args) - ------------------------------------------------------------------------------ -Removing duplicates from a list of definitions. - -> removeDuplicateDefinitions -> :: [(DefExpr,(Id,DefExpr))] -- (label,(id,rhs)) -> -> UniqSM [(Id,DefExpr)] - -> removeDuplicateDefinitions defs = -> foldrSUs rem ([],[]) defs `thenUs` \(newdefs,s) -> -> mapUs (\(l,(f,e)) -> subst s e `thenUs` \e -> -> returnUs (f, e)) newdefs -> where - -> rem d@(l,(f,e)) (defs,s) = -> findDup l defs `thenUs` \maybe -> -> case maybe of -> Nothing -> returnUs (d:defs,s) -> Just g -> returnUs (defs, (f,(Var.DefArgVar) g):s) - -We insist that labels rename in both directions, is this necessary? - -> findDup l [] = returnUs Nothing -> findDup l ((l',(f,e)):defs) = -> renameExprs l l' `thenUs` \r -> -> case r of -> IsRenaming _ -> renameExprs l' l `thenUs` \r -> -> case r of -> IsRenaming r -> returnUs (Just f) -> _ -> findDup l defs -> _ -> findDup l defs diff --git a/ghc/compiler/deforest/Def2Core.lhs b/ghc/compiler/deforest/Def2Core.lhs deleted file mode 100644 index 26890c0..0000000 --- a/ghc/compiler/deforest/Def2Core.lhs +++ /dev/null @@ -1,156 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 -% -\section[Def2Core]{Translate a DefProgram back into a CoreProgram} - ->#include "HsVersions.h" -> -> module Def2Core ( -> def2core, d2c, -> -> -- and to make the interface self-sufficient, all this stuff: -> DefBinding(..), SYN_IE(UniqSM), -> GenCoreBinding, Id, DefBindee, -> defPanic -> ) where - -> import DefSyn -> import DefUtils -> -> import Outputable -> import Pretty -> import UniqSupply -> import Util - - -> def2core :: DefProgram -> UniqSM [CoreBinding] -> def2core prog = mapUs defBinding2core prog - -> defBinding2core :: DefBinding -> UniqSM CoreBinding -> defBinding2core (NonRec v e) = -> d2c e `thenUs` \e' -> -> returnUs (NonRec v e') -> defBinding2core (Rec bs) = -> mapUs recBind2core bs `thenUs` \bs' -> -> returnUs (Rec bs') -> where recBind2core (v,e) -> = d2c e `thenUs` \e' -> -> returnUs (v, e') - - -> defAtom2core :: DefAtom -> UniqSM (CoreArg, Maybe CoreExpr) -> defAtom2core atom = case atom of -> LitArg l -> returnUs (LitArg l, Nothing) -> VarArg (DefArgVar id) -> returnUs (VarArg id, Nothing) -> VarArg (DefArgExpr (Var (DefArgVar id))) -> -> returnUs (VarArg id, Nothing) -> VarArg (DefArgExpr (Lit l)) -> -> returnUs (LitArg l, Nothing) -> VarArg (DefArgExpr e) -> -> d2c e `thenUs` \e' -> -> newTmpId (coreExprType e') `thenUs` \new_id -> -> returnUs (VarArg new_id, Just e') -> VarArg (Label _ _) -> -> panic "Def2Core(defAtom2core): VarArg (Label _ _)" - -> d2c :: DefExpr -> UniqSM CoreExpr -> d2c e = case e of -> -> Var (DefArgExpr e) -> -> panic "Def2Core(d2c): Var (DefArgExpr _)" -> -> Var (Label _ _) -> -> panic "Def2Core(d2c): Var (Label _ _)" -> -> Var (DefArgVar v) -> -> returnUs (Var v) -> -> Lit l -> -> returnUs (Lit l) -> -> Con c ts as -> -> mapUs defAtom2core as `thenUs` \atom_expr_pairs -> -> returnUs ( -> foldr (\(a,b) -> mkLet a b) -> (Con c ts (map fst atom_expr_pairs)) -> atom_expr_pairs) -> -> Prim op ts as -> -> mapUs defAtom2core as `thenUs` \atom_expr_pairs -> -> returnUs ( -> foldr (\(a,b) -> mkLet a b) -> (Prim op ts (map fst atom_expr_pairs)) -> atom_expr_pairs) -> -> Lam vs e -> -> d2c e `thenUs` \e' -> -> returnUs (Lam vs e') -> -> CoTyLam alpha e -> -> d2c e `thenUs` \e' -> -> returnUs (CoTyLam alpha e') -> -> App e v -> -> d2c e `thenUs` \e' -> -> defAtom2core v `thenUs` \(v',e'') -> -> returnUs (mkLet v' e'' (App e' v')) -> -> CoTyApp e t -> -> d2c e `thenUs` \e' -> -> returnUs (CoTyApp e' t) -> -> Case e ps -> -> d2c e `thenUs` \e' -> -> defCaseAlts2Core ps `thenUs` \ps' -> -> returnUs (Case e' ps') -> -> Let b e -> -> d2c e `thenUs` \e' -> -> defBinding2core b `thenUs` \b' -> -> returnUs (Let b' e') -> -> SCC l e -> -> d2c e `thenUs` \e' -> -> returnUs (SCC l e') -> Coerce _ _ _ -> -> panic "Def2Core:Coerce" - -> defCaseAlts2Core :: DefCaseAlternatives -> -> UniqSM CoreCaseAlts -> -> defCaseAlts2Core alts = case alts of -> AlgAlts alts dflt -> -> mapUs algAlt2Core alts `thenUs` \alts' -> -> defAlt2Core dflt `thenUs` \dflt' -> -> returnUs (AlgAlts alts' dflt') -> -> PrimAlts alts dflt -> -> mapUs primAlt2Core alts `thenUs` \alts' -> -> defAlt2Core dflt `thenUs` \dflt' -> -> returnUs (PrimAlts alts' dflt') -> -> where -> -> algAlt2Core (c, vs, e) = d2c e `thenUs` \e' -> returnUs (c, vs, e') -> primAlt2Core (l, e) = d2c e `thenUs` \e' -> returnUs (l, e') -> -> defAlt2Core NoDefault = returnUs NoDefault -> defAlt2Core (BindDefault v e) = -> d2c e `thenUs` \e' -> -> returnUs (BindDefault v e') - -> mkLet :: CoreArg -> -> Maybe CoreExpr -> -> CoreExpr -> -> CoreExpr -> -> mkLet (VarArg v) (Just e) e' = Let (NonRec v e) e' -> mkLet v Nothing e' = e' - ------------------------------------------------------------------------------ -XXX - in here becuase if it goes in DefUtils we've got mutual recursion. - -> defPanic :: String -> String -> DefExpr -> UniqSM a -> defPanic modl fun expr = -> d2c expr `thenUs` \expr -> -> panic (modl ++ "(" ++ fun ++ "): " ++ show (ppr PprDebug expr)) diff --git a/ghc/compiler/deforest/DefExpr.lhs b/ghc/compiler/deforest/DefExpr.lhs deleted file mode 100644 index 57a2230..0000000 --- a/ghc/compiler/deforest/DefExpr.lhs +++ /dev/null @@ -1,659 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 -% -\section[DefExpr]{Transformation Algorithm for Expressions} - ->#include "HsVersions.h" - -> module DefExpr ( -> tran -> ) where -> -> import DefSyn -> import CoreSyn -> import DefUtils -> import Core2Def ( c2d ) -- for unfoldings -> import TreelessForm -> import Cyclic - -> import Type ( applyTypeEnvToTy, -> SYN_IE(SigmaType), Type -> ) -> import CmdLineOpts ( SwitchResult, switchIsOn ) -> import CoreUnfold ( Unfolding(..) ) -> import CoreUtils ( mkValLam, unTagBinders, coreExprType ) -> import Id ( applyTypeEnvToId, getIdUnfolding, Id, -> isInstId_maybe -> ) -> import Inst -- Inst(..) -> import IdInfo -> import Outputable -> import UniqSupply -> import Util - -> -- tmp -> import Pretty -> import Def2Core - ------------------------------------------------------------------------------ -Top level transformation - -A type environment mapping type variables to types is carried around. -This is extended by one rule only: reduction of a type application. - -> tran -> :: SwitchChecker who_knows -> -> IdEnv DefExpr -- Environment -> -> TypeEnv -- Type environment -> -> DefExpr -- input expression -> -> [DefCoreArg] -- args -> -> UniqSM DefExpr - -> tran sw p t e@(Var (DefArgVar id)) as = -> tranVar sw p id -> ( -> mapArgs (\e -> tran sw p t e []) as `thenUs` \as -> -> returnUs (mkGenApp (Var (DefArgVar new_id)) as) -> ) -> ( -> \e -> -> tran sw p t e as `thenUs` \e -> -> returnUs (mkLabel (mkGenApp (Var (DefArgVar new_id)) -> (map (substTyArg t) as)) -> e) -> ) -> where new_id = applyTypeEnvToId t id - -> tran sw p t e@(Lit l) [] = -> returnUs e -> -> tran sw p t (Con c ts es) [] = -> mapUs (tranAtom sw p t) es `thenUs` \es -> -> returnUs (Con c (map (applyTypeEnvToTy t) ts) es) -> -> tran sw p t (Prim op ts es) [] = -- XXX constant folding? -> mapUs (tranAtom sw p t) es `thenUs` \es -> -> returnUs (Prim op (map (applyTypeEnvToTy t) ts) es) -> -> tran sw p t (Lam vs e) [] = -> tran sw p t e [] `thenUs` \e -> -> returnUs (mkValLam (map (applyTypeEnvToId t) vs) e) -> -> tran sw p t (Lam vs e) as = -> subst s e `thenUs` \e -> -> tran sw p t (mkValLam rvs e) ras -> where -> (rvs,ras,s) = mkSubst vs as [] - -> tran sw p t (CoTyLam alpha e) [] = -> tran sw p t e [] `thenUs` \e -> -> returnUs (CoTyLam alpha e) -> - - ToDo: use the environment rather than doing explicit substitution - (didn't work last time I tried :) - -> tran sw p t (CoTyLam alpha e) (TypeArg ty : as) = -> tran sw p t (applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e) as - -> tran sw p t (App e v) as = -> maybeJumbleApp e v `thenUs` \j -> -> case j of -> Nothing -> tran sw p t e (ValArg v : as) -> Just e' -> tran sw p t e' as -> -> tran sw p t (CoTyApp e ty) as = -> tran sw p t e (TypeArg (applyTypeEnvToTy t ty) : as) -> -> tran sw p t (Let (NonRec v e) e') as = -> tran sw p t e [] `thenUs` \e -> -> if isConstant e then -> trace "yippee!!" $ -> subst [(v,removeLabels e)] e' `thenUs` \e' -> -> tran sw p t e' as -> else -> tran sw p t e' as `thenUs` \e' -> -> returnUs (Let (NonRec (applyTypeEnvToId t v) e) e') -> -> tran sw p t (Let (Rec bs) e) as = -> tranRecBinds sw p t bs e `thenUs` \(p',resid,e) -> -> tran sw p' t e as `thenUs` \e -> -> returnUs (mkDefLetrec resid e) -> -> tran sw p t (SCC l e) as = -> tran sw p t e [] `thenUs` \e -> -> mapArgs (\e -> tran sw p t e []) as `thenUs` \as -> -> returnUs (mkGenApp (SCC l e) as) -> -> tran sw p t (Coerce c ty e) as = -> panic "DefExpr:tran:Coerce" -> -> tran sw p t (Case e ps) as = -> tranCase sw p t e [] ps as -> -> tran _ _ _ e as = -> defPanic "DefExpr" "tran" (mkGenApp e as) - ------------------------------------------------------------------------------ -Transformation for case expressions of the form (case e1..en of {..}) - -> tranCase -> :: SwitchChecker who_knows -> -> IdEnv DefExpr -> -> TypeEnv -> -> DefExpr -> -> [DefCoreArg] -> -> DefCaseAlternatives -> -> [DefCoreArg] -> -> UniqSM DefExpr - -> tranCase sw p t e bs ps as = case e of -> -> Var (DefArgVar id) -> -> tranVar sw p id -> ( -> tranAlts sw p t ps as `thenUs` \ps -> -> mapArgs (\e -> tran sw p t e []) bs `thenUs` \bs -> -> returnUs -> (Case -> (mkGenApp (Var (DefArgVar -> (applyTypeEnvToId t id))) -> bs) -> ps) -> ) -> ( -> \e -> -> tranCase sw p t e bs ps as `thenUs` \e -> -> returnUs -> (mkLabel -> (mkGenApp -> (Case (mkGenApp (Var (DefArgVar id)) -> (map (substTyArg t) bs)) -> ps) -> (map (substTyArg t) as)) -> e) -> ) -> -> Lit l -> -> case bs of -> [] -> tranAlts sw p t ps as `thenUs` \ps -> -> returnUs (Case e ps) -> _ -> die_horribly -> -> Prim op ts es -> -> case bs of -> [] -> tranAlts sw p t ps as `thenUs` \ps -> -> mapUs (tranAtom sw p t) es `thenUs` \es -> -> returnUs (Case (Prim op -> (map (applyTypeEnvToTy t) ts) es) ps) -> _ -> die_horribly -> -> Con c ts es -> -> case bs of -> [] -> case ps of -> AlgAlts alts def -> -> reduceCase sw p c ts es alts def as -> PrimAlts alts def -> die_horribly -> _ -> die_horribly -> -> Lam vs e -> -> case bs of -> [] -> die_horribly -> (TypeArg _ : _) -> die_horribly -> _ -> subst s e `thenUs` \e -> -> tranCase sw p t e rbs ps as -> where -> (rvs,rbs,s) = mkSubst vs bs [] -> -> CoTyLam alpha e -> -> case bs of -> TypeArg ty : bs' -> tranCase sw p t e' bs' ps as -> where e' = applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e -> _ -> die_horribly -> -> App e v -> -> maybeJumbleApp e v `thenUs` \j -> -> case j of -> Nothing -> tranCase sw p t e (ValArg v : bs) ps as -> Just e' -> tranCase sw p t e' bs ps as -> -> CoTyApp e ty -> -> tranCase sw p t e (TypeArg (applyTypeEnvToTy t ty) : bs) -> ps as -> -> Let (NonRec v e) e' -> -> tran sw p t e [] `thenUs` \e -> -> if isConstant e then -> trace "yippee2!!" $ -> subst [(v,removeLabels e)] e' `thenUs` \e' -> -> tranCase sw p t e' bs ps as -> else -> tranCase sw p t e' bs ps as `thenUs` \e' -> -> returnUs (Let (NonRec -> (applyTypeEnvToId t v) e) e') -> -> Let (Rec binds) e -> -> tranRecBinds sw p t binds e `thenUs` \(p',resid,e) -> -> tranCase sw p' t e bs ps as `thenUs` \e -> -> returnUs (mkDefLetrec resid e) -> -> -- ToDo: sort out cost centres. Currently they act as a barrier -> -- to optimisation. -> SCC l e -> -> tran sw p t e [] `thenUs` \e -> -> mapArgs (\e -> tran sw p t e []) bs -> `thenUs` \bs -> -> tranAlts sw p t ps as `thenUs` \ps -> -> returnUs (Case (mkGenApp (SCC l e) bs) -> ps) -> -> Coerce _ _ _ -> panic "DefExpr:tranCase:Coerce" -> -> Case e ps' -> -> tranCase sw p t e [] -> (mapAlts (\e -> mkGenApp (Case e ps) bs) ps') as -> -> _ -> die_horribly -> -> where die_horribly = defPanic "DefExpr" "tranCase" -> (mkGenApp (Case (mkGenApp e bs) ps) as) - ------------------------------------------------------------------------------ -Deciding whether or not to replace a function variable with it's -definition. The tranVar function is passed four arguments: the -environment, the Id itself, the expression to return if no -unfolding takes place, and a function to apply to the unfolded expression -should an unfolding be required. - -> tranVar -> :: SwitchChecker who_knows -> -> IdEnv DefExpr -> -> Id -> -> UniqSM DefExpr -> -> (DefExpr -> UniqSM DefExpr) -> -> UniqSM DefExpr -> -> tranVar sw p id no_unfold unfold_with = -> -> case lookupIdEnv p id of -> Just e' -> -> rebindExpr e' `thenUs` \e' -> -> if deforestable id -> then unfold_with e' -> else panic "DefExpr(tran): not deforestable id in env" - - No mapping in the environment, but it could be an - imported function that was annotated with DEFOREST, - in which case it will have an unfolding inside the Id - itself. - -> Nothing -> -> if (not . deforestable) id -> then no_unfold -> -> else case (getIdUnfolding id) of -> SimpleUnfolding _ expr guidance -> -> panic "DefExpr:SimpleUnfolding has changed a little; needs mod here" -> -- SLPJ March 95 -> ->--??? -- ToDo: too much overhead here. ->--??? let e' = c2d nullIdEnv expr in ->--??? convertToTreelessForm sw e' `thenUs` \e'' -> ->--??? unfold_with e'' -> _ -> no_unfold - - If the unfolding isn't present, this is - a sign that the function is from this module and - is not in the environemnt yet (maybe because - we are transforming the body of the definition - itself). - -> {- panic -> ("DefExpr(tran): Deforestable id `" -> ++ show (ppr PprDebug id) -> ++ "' doesn't have an unfolding.") -} - ------------------------------------------------------------------------------ -Transform a set of case alternatives. - -> tranAlts -> :: SwitchChecker who_knows -> -> IdEnv DefExpr -> -> TypeEnv -> -> DefCaseAlternatives -> -> [DefCoreArg] -> -> UniqSM DefCaseAlternatives - -> tranAlts sw p t (AlgAlts alts def) as = -> mapUs (tranAlgAlt sw p t as) alts `thenUs` \alts -> -> tranDefault sw p t def as `thenUs` \def -> -> returnUs (AlgAlts alts def) -> tranAlts sw p t (PrimAlts alts def) as = -> mapUs (tranPrimAlt sw p t as) alts `thenUs` \alts -> -> tranDefault sw p t def as `thenUs` \def -> -> returnUs (PrimAlts alts def) - -> tranAlgAlt sw p t as (c, vs, e) = -> tran sw p t e as `thenUs` \e -> -> returnUs (c, map (applyTypeEnvToId t) vs, e) -> tranPrimAlt sw p t as (l, e) = -> tran sw p t e as `thenUs` \e -> -> returnUs (l, e) -> -> tranDefault sw p t NoDefault as = returnUs NoDefault -> tranDefault sw p t (BindDefault v e) as = -> tran sw p t e as `thenUs` \e -> -> returnUs (BindDefault (applyTypeEnvToId t v) e) - ------------------------------------------------------------------------------ -Transform an atom. - -> tranAtom -> :: SwitchChecker who_knows -> -> IdEnv DefExpr -> -> TypeEnv -> -> DefAtom -> -> UniqSM DefAtom - -> tranAtom sw p t (VarArg v) = -> tranArg sw p t v `thenUs` \v -> -> returnUs (VarArg v) -> tranAtom sw p t e@(LitArg l) = -- XXX -> returnUs e - -> tranArg sw p t (DefArgExpr e) = -> tran sw p t e [] `thenUs` \e -> -> returnUs (DefArgExpr e) -> tranArg sw p t e@(Label _ _) = -> defPanic "DefExpr" "tranArg" (Var e) -> tranArg sw p t (DefArgVar v) = -> tran sw p t (Var (DefArgVar v)) [] `thenUs` \e -> -> returnUs (DefArgExpr e) -- XXX remove this case - ------------------------------------------------------------------------------ -Translating recursive definition groups. - -We first transform each binding, and then seperate the results into -deforestable and non-deforestable sets of bindings. The deforestable -bindings are processed by the knot-tyer, and added to the current -environment. The rest of the bindings are returned as residual. - -ToDo: conversion to treeless form should be unnecessary here, becuase -the transformer/knot-tyer should leave things in treeless form. - -> tranRecBinds sw p t bs e = - -Transform all the deforestable definitions, yielding - (extracted,rhss) -list of extracted functions = concat extracted ok, so let's get the -total set of free variables of the whole function set, call this set -fvs. Expand the argument list of each function by - (fvs - freeVars rhs) -and substitute the new function calls throughout the function set. - - -> let -> (unfold,resid) = partition (deforestable . fst) bs -> in - -> mapUs (tranRecBind sw p t) unfold `thenUs` \unfold -> -> mapUs (tranRecBind sw p t) resid `thenUs` \resid -> - - Tie knots in the deforestable right-hand sides, and convert the - results to treeless form. Then extract any nested deforestable - recursive functions, and place everything we've got in the new - environment. - -> let (vs,es) = unzip unfold in -> mapUs mkLoops es `thenUs` \res -> -> let -> (extracted,new_rhss) = unzip res -> new_binds = zip vs new_rhss ++ concat extracted -> in - - Convert everything to treeless form (these functions aren't - necessarily already in treeless form because the functions - bound in this letrec are about to change status from not - unfolded to unfolded). - -> mapUs (\(v,e) -> -> convertToTreelessForm sw e `thenUs` \e -> -> returnUs (v,e)) new_binds `thenUs` \fs -> - - Now find the total set of free variables of this function set. - -> let -> fvs = filter (\id -> isArgId id{- && (not . isLitId) id-}) -> (foldr union [] (map freeVars (map snd fs))) -> in - - Now expand the argument lists to include the total set of free vars. - -> let -> stuff = [ fixupFreeVars fvs id e | (id,e) <- fs ] -> fs' = map fst stuff -> s = concat (map snd stuff) -> subIt (id,e) = subst s e `thenUs` \e -> returnUs (id,e) -> in -> subst s e `thenUs` \e -> -> mapUs subIt resid `thenUs` \resid -> -> mapUs subIt fs' `thenUs` \fs -> - -> let res = returnUs (growIdEnvList p fs, resid, e) in -> case unzip fs of -> (evs,ees) -> mapUs d2c ees `thenUs` \ees -> -> let (vs',es') = unzip bs in -> mapUs d2c es' `thenUs` \es' -> -> trace ("extraction " -> ++ showIds (map fst bs) -> ++ showIds evs -> ++ "\n{ input:\n" ++ (concat (map showBind (zip vs' es'))) ++ "}\n" -> ++ "{ result:\n" ++ (concat (map showBind (zip evs ees))) ++ "}\n") res -> where showBind (v,e) = show (ppr PprDebug v) ++ "=\n" ++ show (ppr PprDebug e) ++ "\n" - -> tranRecBind sw p t (id,e) = -> tran sw p t e [] `thenUs` \e -> -> returnUs (applyTypeEnvToId t id,e) - -> showIds :: [Id] -> String -> showIds ids = "(" ++ concat (map ((' ' :) . show . ppr PprDebug) ids) -> ++ " )" - ------------------------------------------------------------------------------ - -> reduceCase sw p c ts es alts def as = -> case [ a | a@(c',vs,e) <- alts, c' == c ] of -> [(c,vs,e)] -> -> subst (zip vs (map atom2expr es)) e `thenUs` \e -> -> tran sw p nullTyVarEnv e as -> [] -> case def of -> NoDefault -> -> panic "DefExpr(reduceCase): no match" -> BindDefault v e -> -> subst [(v,Con c ts es)] e `thenUs` \e -> -> tran sw p nullTyVarEnv e as -> _ -> panic "DefExpr(reduceCase): multiple matches" - ------------------------------------------------------------------------------ -Type Substitutions. - -> applyTypeEnvToExpr -> :: TypeEnv -> -> DefExpr -> -> DefExpr - -> applyTypeEnvToExpr p e = substTy e -> where -> substTy e' = case e' of -> Var (DefArgExpr e) -> panic "DefExpr(substTy): Var (DefArgExpr _)" -> Var (Label l e) -> panic "DefExpr(substTy): Var (Label _ _)" -> Var (DefArgVar id) -> Var (DefArgVar (applyTypeEnvToId p id)) -> Lit l -> e' -> Con c ts es -> -> Con c (map (applyTypeEnvToTy p) ts) (map substTyAtom es) -> Prim op ts es -> -> Prim op (map (applyTypeEnvToTy p) ts) (map substTyAtom es) -> Lam vs e -> Lam (map (applyTypeEnvToId p) vs) (substTy e) -> CoTyLam alpha e -> CoTyLam alpha (substTy e) -> App e v -> App (substTy e) (substTyAtom v) -> CoTyApp e t -> CoTyApp (substTy e) (applyTypeEnvToTy p t) -> Case e ps -> Case (substTy e) (substTyCaseAlts ps) -> Let (NonRec id e) e' -> -> Let (NonRec (applyTypeEnvToId p id) (substTy e)) -> (substTy e') -> Let (Rec bs) e -> -> Let (Rec (map substTyRecBind bs)) (substTy e) -> where substTyRecBind (v,e) = (applyTypeEnvToId p v, substTy e) -> SCC l e -> SCC l (substTy e) -> Coerce _ _ _ -> panic "DefExpr:applyTypeEnvToExpr:Coerce" - -> substTyAtom :: DefAtom -> DefAtom -> substTyAtom (VarArg v) = VarArg (substTyArg v) -> substTyAtom (LitArg l) = LitArg l -- XXX - -> substTyArg :: DefBindee -> DefBindee -> substTyArg (DefArgExpr e) = DefArgExpr (substTy e) -> substTyArg e@(Label _ _) = panic "DefExpr(substArg): Label _ _" -> substTyArg e@(DefArgVar id) = -- XXX -> DefArgVar (applyTypeEnvToId p id) - -> substTyCaseAlts (AlgAlts as def) -> = AlgAlts (map substTyAlgAlt as) (substTyDefault def) -> substTyCaseAlts (PrimAlts as def) -> = PrimAlts (map substTyPrimAlt as) (substTyDefault def) - -> substTyAlgAlt (c, vs, e) = (c, map (applyTypeEnvToId p) vs, substTy e) -> substTyPrimAlt (l, e) = (l, substTy e) - -> substTyDefault NoDefault = NoDefault -> substTyDefault (BindDefault id e) = -> BindDefault (applyTypeEnvToId p id) (substTy e) - -> substTyArg t (ValArg e) = -> ValArg (VarArg (DefArgExpr (applyTypeEnvToExpr t (atom2expr e)))) -> substTyArg t (TypeArg ty) = TypeArg ty - ------------------------------------------------------------------------------ - -> mapAlts f ps = case ps of -> AlgAlts alts def -> -> AlgAlts (map (\(c,vs,e) -> (c,vs,f e)) alts) (mapDef f def) -> PrimAlts alts def -> -> PrimAlts (map (\(l,e) -> (l, f e)) alts) (mapDef f def) -> -> mapDef f NoDefault = NoDefault -> mapDef f (BindDefault v e) = BindDefault v (f e) - ------------------------------------------------------------------------------ -Apply a function to all the ValArgs in an Args list. - -> mapArgs -> :: (DefExpr -> UniqSM DefExpr) -> -> [DefCoreArg] -> -> UniqSM [DefCoreArg] -> -> mapArgs f [] = -> returnUs [] -> mapArgs f (a@(TypeArg ty) : as) = -> mapArgs f as `thenUs` \as -> -> returnUs (a:as) -> mapArgs f (ValArg v : as) = -> f (atom2expr v) `thenUs` \e -> -> mapArgs f as `thenUs` \as -> -> returnUs (ValArg (VarArg (DefArgExpr e)) : as) -> - -> mkSubst [] as s = ([],as,s) -> mkSubst vs [] s = (vs,[],s) -> mkSubst (v:vs) (ValArg e:as) s = mkSubst vs as ((v,atom2expr e):s) - ------------------------------------------------------------------------------ - -The next function does a bit of extraction for applicative terms -before they are transformed. We look for boring expressions - those -that won't be any use in removing intermediate data structures. These -include applicative terms where we cannot unfold the head, -non-reducible case expressions, primitive applications and some let -bindings. - -Extracting these expressions helps the knot-tyer to find loops -earlier, and avoids the need to do matching instead of renaming. - -We also pull out lets from function arguments, and primitive case -expressions (which can't fail anyway). - -Think: - - (t (case u of x -> v)) - ====> - let x = u in t v - -Maybe shouldn't do this if -fpedantic-bottoms? Also can't do it if u -has an unboxed type. - -ToDo: sort this mess out - could be more efficient. - -> maybeJumbleApp :: DefExpr -> DefAtom -> UniqSM (Maybe DefExpr) -> maybeJumbleApp e (LitArg _) = returnUs Nothing -- ToDo remove -> maybeJumbleApp e (VarArg (DefArgExpr (Var (DefArgVar _)))) -> = returnUs Nothing -> maybeJumbleApp e (VarArg (DefArgExpr t)) -> = let t' = pull_out t [] in -> case t' of -> Let _ _ -> returnUs (Just t') -> Case (Prim _ _ _) (PrimAlts [] _) -> returnUs (Just t') -> _ -> if isBoringExpr t then -> rebind_with_let t -> else -> returnUs Nothing - -> where isBoringExpr (Var (DefArgVar z)) = (not . deforestable) z -> isBoringExpr (Prim op ts es) = True -> isBoringExpr (Case e ps) = isBoringExpr e -> && boringCaseAlternatives ps -> isBoringExpr (App l r) = isBoringExpr l -> isBoringExpr (CoTyApp l t) = isBoringExpr l -> isBoringExpr _ = False -> -> boringCaseAlternatives (AlgAlts as d) = -> all boringAlgAlt as && boringDefault d -> boringCaseAlternatives (PrimAlts as d) = -> all boringPrimAlt as && boringDefault d -> -> boringAlgAlt (c,xs,e) = isBoringExpr e -> boringPrimAlt (l,e) = isBoringExpr e -> -> boringDefault NoDefault = True -> boringDefault (BindDefault x e) = isBoringExpr e - -> pull_out (Let b t) as = Let b (pull_out t as) -> pull_out (App l r) as = pull_out l (r:as) -> pull_out (Case prim@(Prim _ _ _) -> (PrimAlts [] (BindDefault x u))) as -> = Case prim (PrimAlts [] (BindDefault x -> (pull_out u as))) -> pull_out t as -> = App e (VarArg (DefArgExpr (foldl App t as))) -> -> rebind_with_let t = -> d2c t `thenUs` \core_t -> -> newDefId (coreExprType core_t) `thenUs` \x -> -> trace "boring epxr found!" $ -> returnUs (Just (Let (NonRec x t) -> (App e (VarArg ( -> DefArgExpr (Var ( -> DefArgVar x))))))) - ------------------------------------------------------------------------------ - -> isLitId id = case isInstId_maybe id of -> Just (LitInst _ _ _ _) -> True -> _ -> False - -> isConstant (Con c [] []) = True -> isConstant (Lit l) = True -> isConstant (Var (Label l e)) = isConstant e -> isConstant _ = False - -> removeLabels (Var (Label l e)) = removeLabels e -> removeLabels e = e diff --git a/ghc/compiler/deforest/DefSyn.lhs b/ghc/compiler/deforest/DefSyn.lhs deleted file mode 100644 index 512d2ad..0000000 --- a/ghc/compiler/deforest/DefSyn.lhs +++ /dev/null @@ -1,59 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 -% -\section[DefSyn]{A temporary datatype for the deforestation pass} - -> module DefSyn where - -> import CoreSyn -> import Outputable -> import Util - -This is exactly the same as core, except that the argument to -application can be an arbitrary expression. - -> type DefProgram = [GenCoreBinding Id DefBindee] -> type DefBinding = GenCoreBinding Id DefBindee -> type DefExpr = GenCoreExpr Id DefBindee -> type DefAtom = GenCoreAtom DefBindee -> type DefCaseAlternatives = GenCoreCaseAlts Id DefBindee -> type DefCaseDefault = GenCoreCaseDefault Id DefBindee - -> type DefCoreArg = GenCoreArg DefBindee - -> data DefBindee -> = DefArgExpr DefExpr -- arbitrary expressions as argumemts -> | DefArgVar Id -- or just ids -> | Label DefExpr DefExpr -- labels for detecting cycles - - -Ok, I've cheated horribly here. Instead of defining a new data type -including the new Label construct, I've just defined a new -parameterisation of Core in which a variable can be one of {variable, -expression, label}. This gives us both arbitrary expressions on the -right hand side of application, in addition to the new Label -construct. - -The penalty for this is that expressions will have extra indirections -as compared with a new datatype. The saving is basically not having -to define a new datatype almost identical to Core. - -Because our parameterised datatype is a little too general (i.e. it -distinguishes expressions that we wish to equate), there are some -invariants that will be adhered to during the transformation. The -following are alternative representations for certain expressions. -The forms on the left are disallowed: - -Var (DefArgExpr e) == e -VarArg (Label l e) == VarArg (DefArgExpr (Var (Label l e))) - -For completeness, we should also have: - -VarArg (DefArgVar v) == VarArg (DefArgExpr (Var (DefArgVar v))) -LitArg l == VarArg (DefArgExpr (Lit l)) - -In other words, atoms must all be of the form (VarArg (DefArgExpr -_)) and the argument to a Var can only be Label or DefArgVar. - -> mkLabel :: DefExpr -> DefExpr -> DefExpr -> mkLabel l e = Var (Label l e) diff --git a/ghc/compiler/deforest/DefUtils.lhs b/ghc/compiler/deforest/DefUtils.lhs deleted file mode 100644 index 9b039d4..0000000 --- a/ghc/compiler/deforest/DefUtils.lhs +++ /dev/null @@ -1,625 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 -% -\section[DefUtils]{Miscellaneous Utility functions} - ->#include "HsVersions.h" - -> module DefUtils ( -> strip, stripAtom, stripCaseAlts, freeVars, renameExprs, rebindExpr, -> atom2expr, newDefId, newTmpId, deforestable, foldrSUs, -> mkDefLetrec, subst, freeTyVars, union, consistent, RenameResult(..), -> isArgId -> ) -> where - -> import DefSyn -> import Def2Core -- tmp, for traces - ->#ifdef __HBC__ -> import Trace ->#endif - -> import Type ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy, -> tyVarsOfType, TyVar, SYN_IE(SigmaType) -> ) -> import Literal ( Literal ) -- for Eq Literal -> import CoreSyn -> import Id ( mkIdWithNewUniq, mkSysLocal, applyTypeEnvToId, -> getIdInfo, toplevelishId, idType, Id ) -> import IdInfo -> import Outputable -> import Pretty -> import PrimOp ( PrimOp ) -- for Eq PrimOp -> import UniqSupply -> import SrcLoc ( noSrcLoc ) -> import Util - ------------------------------------------------------------------------------ -\susbsection{Strip} - -Implementation of the strip function. Strip is the identity on -expressions (recursing into subterms), but replaces each label with -its left hand side. The result is a term with no labels. - -> strip :: DefExpr -> DefExpr - -> strip e' = case e' of -> Var (DefArgExpr e) -> panic "DefUtils(strip): Var (DefExpr _)" -> Var (Label l e) -> l -> Var (DefArgVar v) -> e' -> Lit l -> e' -> Con c ts es -> Con c ts (map stripAtom es) -> Prim op ts es -> Prim op ts (map stripAtom es) -> Lam vs e -> Lam vs (strip e) -> CoTyLam alpha e -> CoTyLam alpha (strip e) -> App e v -> App (strip e) (stripAtom v) -> CoTyApp e t -> CoTyApp (strip e) t -> Case e ps -> Case (strip e) (stripCaseAlts ps) -> Let (NonRec v e) e' -> Let (NonRec v (strip e)) (strip e') -> Let (Rec bs) e -> -> Let (Rec [ (v, strip e) | (v,e) <- bs ]) (strip e) -> SCC l e -> SCC l (strip e) -> Coerce _ _ _ -> panic "DefUtils:strip:Coerce" - -> stripAtom :: DefAtom -> DefAtom -> stripAtom (VarArg v) = VarArg (stripArg v) -> stripAtom (LitArg l) = LitArg l -- XXX - -> stripArg :: DefBindee -> DefBindee -> stripArg (DefArgExpr e) = DefArgExpr (strip e) -> stripArg (Label l e) = panic "DefUtils(stripArg): Label _ _" -> stripArg (DefArgVar v) = panic "DefUtils(stripArg): DefArgVar _ _" - -> stripCaseAlts (AlgAlts as def) -> = AlgAlts (map stripAlgAlt as) (stripDefault def) -> stripCaseAlts (PrimAlts as def) -> = PrimAlts (map stripPrimAlt as) (stripDefault def) - -> stripAlgAlt (c, vs, e) = (c, vs, strip e) -> stripPrimAlt (l, e) = (l, strip e) - -> stripDefault NoDefault = NoDefault -> stripDefault (BindDefault v e) = BindDefault v (strip e) - ------------------------------------------------------------------------------ -\subsection{Free Variables} - -Find the free variables of an expression. With labels, we descend -into the left side since this is the only sensible thing to do. -Strictly speaking, for a term (Label l e), freeVars l == freeVars e, -but l is guranteed to be finite so we choose that one. - -> freeVars :: DefExpr -> [Id] -> freeVars e = free e [] -> where -> free e fvs = case e of -> Var (DefArgExpr e) -> -> panic "DefUtils(free): Var (DefExpr _)" -> Var (Label l e) -> free l fvs -> Var (DefArgVar v) -> | v `is_elem` fvs -> fvs -> | otherwise -> v : fvs -> where { is_elem = isIn "freeVars(deforest)" } -> Lit l -> fvs -> Con c ts es -> foldr freeAtom fvs es -> Prim op ts es -> foldr freeAtom fvs es -> Lam vs e -> free' vs (free e fvs) -> CoTyLam alpha e -> free e fvs -> App e v -> free e (freeAtom v fvs) -> CoTyApp e t -> free e fvs -> Case e ps -> free e (freeCaseAlts ps fvs) -> Let (NonRec v e) e' -> free e (free' [v] (free e' fvs)) -> Let (Rec bs) e -> free' vs (foldr free (free e fvs) es) -> where (vs,es) = unzip bs -> SCC l e -> free e fvs -> Coerce _ _ _ -> panic "DefUtils.freeVars:Coerce" - -> free' :: [Id] -> [Id] -> [Id] -> free' vs fvs = filter (\x -> notElem x vs) fvs - -> freeAtom (VarArg (DefArgExpr e)) fvs = free e fvs -> freeAtom (VarArg (Label l e)) fvs -> = panic "DefUtils(free): VarArg (Label _ _)" -> freeAtom (VarArg (DefArgVar v)) fvs -> = panic "DefUtils(free): VarArg (DefArgVar _ _)" -> freeAtom (LitArg l) fvs = fvs - -> freeCaseAlts (AlgAlts as def) fvs -> = foldr freeAlgAlt (freeDefault def fvs) as -> freeCaseAlts (PrimAlts as def) fvs -> = foldr freePrimAlt (freeDefault def fvs) as -> -> freeAlgAlt (c, vs, e) fvs = free' vs (free e fvs) -> freePrimAlt (l, e) fvs = free e fvs - -> freeDefault NoDefault fvs = fvs -> freeDefault (BindDefault v e) fvs = free' [v] (free e fvs) - ------------------------------------------------------------------------------ -\subsection{Free Type Variables} - -> freeTyVars :: DefExpr -> [TyVar] -> freeTyVars e = free e [] -> where -> free e tvs = case e of -> Var (DefArgExpr e) -> -> panic "DefUtils(freeVars): Var (DefExpr _)" -> Var (Label l e) -> free l tvs -> Var (DefArgVar id) -> freeId id tvs -> Lit l -> tvs -> Con c ts es -> foldr freeTy (foldr freeAtom tvs es) ts -> Prim op ts es -> foldr freeTy (foldr freeAtom tvs es) ts -> Lam vs e -> foldr freeId (free e tvs) vs -> CoTyLam alpha e -> filter (/= alpha) (free e tvs) -> App e v -> free e (freeAtom v tvs) -> CoTyApp e t -> free e (freeTy t tvs) -> Case e ps -> free e (freeCaseAlts ps tvs) -> Let (NonRec v e) e' -> free e (freeId v (free e' tvs)) -> Let (Rec bs) e -> foldr freeBind (free e tvs) bs -> SCC l e -> free e tvs -> Coerce _ _ _ -> panic "DefUtils.freeTyVars:Coerce" -> -> freeId id tvs = tyVarsOfType (idType id) `union` tvs -> freeTy t tvs = tyVarsOfType t `union` tvs -> freeBind (v,e) tvs = freeId v (free e tvs) - -> freeAtom (VarArg (DefArgExpr e)) tvs = free e tvs -> freeAtom (VarArg (Label l e)) tvs -> = panic "DefUtils(freeVars): VarArg (Label _ _)" -> freeAtom (VarArg (DefArgVar v)) tvs -> = panic "DefUtils(freeVars): VarArg (DefArgVar _ _)" -> freeAtom (LitArg l) tvs = tvs -- XXX - -> freeCaseAlts (AlgAlts as def) tvs -> = foldr freeAlgAlt (freeDefault def tvs) as -> freeCaseAlts (PrimAlts as def) tvs -> = foldr freePrimAlt (freeDefault def tvs) as - -> freeAlgAlt (c, vs, e) tvs = foldr freeId (free e tvs) vs -> freePrimAlt (l, e) tvs = free e tvs - -> freeDefault NoDefault tvs = tvs -> freeDefault (BindDefault v e) tvs = freeId v (free e tvs) - ------------------------------------------------------------------------------ -\subsection{Rebinding variables in an expression} - -Here is the code that renames all the bound variables in an expression -with new uniques. Free variables are left unchanged. - -> rebindExpr :: DefExpr -> UniqSM DefExpr -> rebindExpr e = uniqueExpr nullIdEnv nullTyVarEnv e - -> uniqueExpr :: IdEnv Id -> TypeEnv -> DefExpr -> UniqSM DefExpr -> uniqueExpr p t e = -> case e of -> Var (DefArgVar v) -> -> returnUs (Var (DefArgVar (lookup v p))) -> -> Var (Label l e) -> -> uniqueExpr p t l `thenUs` \l -> -> uniqueExpr p t e `thenUs` \e -> -> returnUs (mkLabel l e) -> -> Var (DefArgExpr _) -> -> panic "DefUtils(uniqueExpr): Var(DefArgExpr _)" -> -> Lit l -> -> returnUs e -> -> Con c ts es -> -> mapUs (uniqueAtom p t) es `thenUs` \es -> -> returnUs (Con c (map (applyTypeEnvToTy t) ts) es) -> -> Prim op ts es -> -> mapUs (uniqueAtom p t) es `thenUs` \es -> -> returnUs (Prim op (map (applyTypeEnvToTy t) ts) es) -> -> Lam vs e -> -> mapUs (newVar t) vs `thenUs` \vs' -> -> uniqueExpr (growIdEnvList p (zip vs vs')) t e `thenUs` \e -> -> returnUs (Lam vs' e) -> -> CoTyLam v e -> -> getUnique `thenUs` \u -> -> let v' = cloneTyVar v u -> t' = addOneToTyVarEnv t v (mkTyVarTy v') in -> uniqueExpr p t' e `thenUs` \e -> -> returnUs (CoTyLam v' e) -> -> App e v -> -> uniqueExpr p t e `thenUs` \e -> -> uniqueAtom p t v `thenUs` \v -> -> returnUs (App e v) -> -> CoTyApp e ty -> -> uniqueExpr p t e `thenUs` \e -> -> returnUs (CoTyApp e (applyTypeEnvToTy t ty)) -> -> Case e alts -> -> uniqueExpr p t e `thenUs` \e -> -> uniqueAlts alts `thenUs` \alts -> -> returnUs (Case e alts) -> where -> uniqueAlts (AlgAlts as d) = -> mapUs uniqueAlgAlt as `thenUs` \as -> -> uniqueDefault d `thenUs` \d -> -> returnUs (AlgAlts as d) -> uniqueAlts (PrimAlts as d) = -> mapUs uniquePrimAlt as `thenUs` \as -> -> uniqueDefault d `thenUs` \d -> -> returnUs (PrimAlts as d) -> -> uniqueAlgAlt (c, vs, e) = -> mapUs (newVar t) vs `thenUs` \vs' -> -> uniqueExpr (growIdEnvList p (zip vs vs')) t e -> `thenUs` \e -> -> returnUs (c, vs', e) -> uniquePrimAlt (l, e) = -> uniqueExpr p t e `thenUs` \e -> -> returnUs (l, e) -> -> uniqueDefault NoDefault = returnUs NoDefault -> uniqueDefault (BindDefault v e) = -> newVar t v `thenUs` \v' -> -> uniqueExpr (addOneToIdEnv p v v') t e `thenUs` \e -> -> returnUs (BindDefault v' e) -> -> Let (NonRec v e) e' -> -> uniqueExpr p t e `thenUs` \e -> -> newVar t v `thenUs` \v' -> -> uniqueExpr (addOneToIdEnv p v v') t e' `thenUs` \e' -> -> returnUs (Let (NonRec v' e) e') -> -> Let (Rec ds) e -> -> let (vs,es) = unzip ds in -> mapUs (newVar t) vs `thenUs` \vs' -> -> let p' = growIdEnvList p (zip vs vs') in -> mapUs (uniqueExpr p' t) es `thenUs` \es -> -> uniqueExpr p' t e `thenUs` \e -> -> returnUs (Let (Rec (zip vs' es)) e) -> -> SCC l e -> -> uniqueExpr p t e `thenUs` \e -> -> returnUs (SCC l e) -> -> Coerce _ _ _ -> panic "DefUtils.uniqueExpr:Coerce" -> -> uniqueAtom :: IdEnv Id -> TypeEnv -> DefAtom -> UniqSM DefAtom -> uniqueAtom p t (LitArg l) = returnUs (LitArg l) -- XXX -> uniqueAtom p t (VarArg v) = -> uniqueArg p t v `thenUs` \v -> -> returnUs (VarArg v) -> -> uniqueArg p t (DefArgVar v) = -> panic "DefUtils(uniqueArg): DefArgVar _ _" -> uniqueArg p t (DefArgExpr e) = -> uniqueExpr p t e `thenUs` \e -> -> returnUs (DefArgExpr e) -> uniqueArg p t (Label l e) = -> panic "DefUtils(uniqueArg): Label _ _" - -We shouldn't need to apply the type environment to free variables, -since their types can only contain type variables that are free in the -expression as a whole (?) - -> lookup :: Id -> IdEnv Id -> Id -> lookup id p = -> case lookupIdEnv p id of -> Nothing -> id -> Just new_id -> new_id - -> newVar :: TypeEnv -> Id -> UniqSM Id -> newVar t id = -> getUnique `thenUs` \u -> -> returnUs (mkIdWithNewUniq (applyTypeEnvToId t id) u) - ------------------------------------------------------------------------------ -\subsection{Detecting Renamings} - -The function `renameExprs' takes two expressions and returns True if -they are renamings of each other. The variables in the list `fs' are -excluded from the renaming process (i.e. if any of these variables -are present in one expression, they cannot be renamed in the other -expression). - -We only allow renaming of sysLocal ids - ie. not top-level, imported -or otherwise global ids. - -> data RenameResult -> = NotRenaming -> | IsRenaming [(Id,Id)] -> | InconsistentRenaming [(Id,Id)] - -> renameExprs :: DefExpr -> DefExpr -> UniqSM RenameResult -> renameExprs u u' = -> case ren u u' of -> [] -> returnUs NotRenaming -> [r] -> if not (consistent r) then -> d2c (strip u) `thenUs` \u -> -> d2c (strip u') `thenUs` \u' -> -> trace ("failed consistency check:\n" ++ -> show (ppr PprDebug u) ++ "\n" ++ -> show (ppr PprDebug u')) -> (returnUs (InconsistentRenaming r)) -> else -> trace "Renaming!" (returnUs (IsRenaming r)) -> _ -> panic "DefUtils(renameExprs)" - -Check that we have a consistent renaming. A renaming is consistent if -each time variable x in expression 1 is renamed, it is renamed to the -same variable. - -> consistent :: [(Id,Id)] -> Bool -> consistent rs = and [ y == y' | (x,y) <- rs, (x',y') <- rs, x == x' ] - -> checkConsistency :: [(Id,Id)] -> [[(Id,Id)]] -> [[(Id,Id)]] -> checkConsistency bound free = [ r' | r <- free, r' <- check r ] -> where -> check r | they're_consistent = [frees] -> | otherwise = [] -> where -> (bounds,frees) = partition (\(a,b) -> a `elem` lbound) r -> (lbound,rbound) = unzip bound -> they're_consistent = consistent (bound ++ bounds) - -Renaming composition operator. - -> (....) :: [[a]] -> [[a]] -> [[a]] -> r .... r' = [ xs ++ xs' | xs <- r, xs' <- r' ] - -The class of identifiers which can be renamed. It is sensible to -disallow renamings of deforestable ids, but the top-level ones are a -bit iffy. Ideally, we should allow renaming of top-level ids, but the -current scheme allows us to leave out the top-level ids from the -argument lists of new function definitions. (we still have the -shadowed ones to worry about..) - -Main renaming function. Returns a list of renamings made while -comparing the expressions. - -> ren :: DefExpr -> DefExpr -> [[(Id,Id)]] -> -> -- renaming or identical cases -- -> -> -> -- same variable, no renaming -> ren (Var (DefArgVar x)) t@(Var (DefArgVar y)) -> | x == y = [[(x,y)]] -> | isArgId x && isArgId y = [[(x,y)]] -> -> -- if we're doing matching, use the next rule, -> -- and delete the second clause in the above rule. -> {- -> ren (Var (DefArgVar x)) t -> | okToRename x && all (not. deforestable) (freeVars t) -> = [[(x,t)]] -> -} - -> ren (Lit l) (Lit l') | l == l' -> = [[]] -> ren (Con c ts es) (Con c' ts' es') | c == c' -> = foldr (....) [[]] (zipWith renAtom es es') -> ren (Prim op ts es) (Prim op' ts' es') | op == op' -> = foldr (....) [[]] (zipWith renAtom es es') -> ren (Lam vs e) (Lam vs' e') -> = checkConsistency (zip vs vs') (ren e e') -> ren (CoTyLam vs e) (CoTyLam vs' e') -> = ren e e' -- XXX! -> ren (App e v) (App e' v') -> = ren e e' .... renAtom v v' -> ren (CoTyApp e t) (CoTyApp e' t') -> = ren e e' -- XXX! -> ren (Case e alts) (Case e' alts') -> = ren e e' .... renAlts alts alts' -> ren (Let (NonRec v a) b) (Let (NonRec v' a') b') -> = ren a a' .... (checkConsistency [(v,v')] (ren b b')) -> ren (Let (Rec ds) e) (Let (Rec ds') e') -> = checkConsistency (zip vs vs') -> (ren e e' .... (foldr (....) [[]] (zipWith ren es es'))) -> where (vs ,es ) = unzip ds -> (vs',es') = unzip ds' -> -> -- label cases -- -> -> ren (Var (Label l e)) e' = ren l e' -> ren e (Var (Label l e')) = ren e l -> -> -- error cases -- -> -> ren (Var (DefArgExpr _)) _ -> = panic "DefUtils(ren): Var (DefArgExpr _)" -> ren _ (Var (DefArgExpr _)) -> = panic "DefUtils(ren): Var (DefArgExpr _)" -> -> -- default case -- -> -> ren _ _ = [] - -Rename atoms. - -> renAtom (VarArg (DefArgExpr e)) (VarArg (DefArgExpr e')) -> = ren e e' -> -- XXX shouldn't need the next two -> renAtom (LitArg l) (LitArg l') | l == l' = [[]] -> renAtom (VarArg (DefArgVar v)) _ = -> panic "DefUtils(renAtom): VarArg (DefArgVar _ _)" -> renAtom _ (VarArg (DefArgVar v)) = -> panic "DefUtils(renAtom): VarArg (DefArgVar _ _)" -> renAtom (VarArg (Label _ _)) _ = -> panic "DefUtils(renAtom): VarArg (Label _ _)" -> renAtom e (VarArg (Label l e')) = -> panic "DefUtils(renAtom): VarArg (Label _ _)" -> -> renAtom _ _ = [] - -Renamings of case alternatives doesn't allow reordering, but that -should be Ok (we don't ever change the ordering anyway). - -> renAlts (AlgAlts as dflt) (AlgAlts as' dflt') -> = foldr (....) [[]] (zipWith renAlgAlt as as') .... renDefault dflt dflt' -> renAlts (PrimAlts as dflt) (PrimAlts as' dflt') -> = foldr (....) [[]] (zipWith renPrimAlt as as') .... renDefault dflt dflt' -> renAlts _ _ = [] -> -> renAlgAlt (c,vs,e) (c',vs',e') | c == c' -> = checkConsistency (zip vs vs') (ren e e') -> renAlgAlt _ _ = [] -> -> renPrimAlt (l,e) (l',e') | l == l' = ren e e' -> renPrimAlt _ _ = [] -> -> renDefault NoDefault NoDefault = [[]] -> renDefault (BindDefault v e) (BindDefault v' e') -> = checkConsistency [(v,v')] (ren e e') - ------------------------------------------------------------------------------ - -> atom2expr :: DefAtom -> DefExpr -> atom2expr (VarArg (DefArgExpr e)) = e -> atom2expr (VarArg (Label l e)) = mkLabel l e -> -- XXX next two should be illegal -> atom2expr (LitArg l) = Lit l -> atom2expr (VarArg (DefArgVar v)) = -> panic "DefUtils(atom2expr): VarArg (DefArgVar _)" - -> expr2atom = VarArg . DefArgExpr - ------------------------------------------------------------------------------ -Grab a new Id and tag it as coming from the Deforester. - -> newDefId :: Type -> UniqSM Id -> newDefId t = -> getUnique `thenUs` \u -> -> returnUs (mkSysLocal SLIT("def") u t noSrcLoc) - -> newTmpId :: Type -> UniqSM Id -> newTmpId t = -> getUnique `thenUs` \u -> -> returnUs (mkSysLocal SLIT("tmp") u t noSrcLoc) - ------------------------------------------------------------------------------ -Check whether an Id was given a `DEFOREST' annotation by the programmer. - -> deforestable :: Id -> Bool -> deforestable id = -> case getDeforestInfo (getIdInfo id) of -> DoDeforest -> True -> Don'tDeforest -> False - ------------------------------------------------------------------------------ -Filter for free variables to abstract from new functions. - -> isArgId id -> = (not . deforestable) id -> && (not . toplevelishId) id - ------------------------------------------------------------------------------ - -> foldrSUs f c [] = returnUs c -> foldrSUs f c (x:xs) -> = foldrSUs f c xs `thenUs` \xs' -> -> f x xs' - ------------------------------------------------------------------------------ - -> mkDefLetrec [] e = e -> mkDefLetrec bs e = Let (Rec bs) e - ------------------------------------------------------------------------------ -Substitutions. - -> subst :: [(Id,DefExpr)] -> -> DefExpr -> -> UniqSM DefExpr - -> subst p e' = sub e' -> where -> p' = mkIdEnv p -> sub e' = case e' of -> Var (DefArgExpr e) -> panic "DefExpr(sub): Var (DefArgExpr _)" -> Var (Label l e) -> panic "DefExpr(sub): Var (Label _ _)" -> Var (DefArgVar v) -> -> case lookupIdEnv p' v of -> Just e -> rebindExpr e `thenUs` \e -> returnUs e -> Nothing -> returnUs e' -> Lit l -> returnUs e' -> Con c ts es -> mapUs substAtom es `thenUs` \es -> -> returnUs (Con c ts es) -> Prim op ts es -> mapUs substAtom es `thenUs` \es -> -> returnUs (Prim op ts es) -> Lam vs e -> sub e `thenUs` \e -> -> returnUs (Lam vs e) -> CoTyLam alpha e -> sub e `thenUs` \e -> -> returnUs (CoTyLam alpha e) -> App e v -> sub e `thenUs` \e -> -> substAtom v `thenUs` \v -> -> returnUs (App e v) -> CoTyApp e t -> sub e `thenUs` \e -> -> returnUs (CoTyApp e t) -> Case e ps -> sub e `thenUs` \e -> -> substCaseAlts ps `thenUs` \ps -> -> returnUs (Case e ps) -> Let (NonRec v e) e' -> -> sub e `thenUs` \e -> -> sub e' `thenUs` \e' -> -> returnUs (Let (NonRec v e) e') -> Let (Rec bs) e -> sub e `thenUs` \e -> -> mapUs substBind bs `thenUs` \bs -> -> returnUs (Let (Rec bs) e) -> where -> substBind (v,e) = -> sub e `thenUs` \e -> -> returnUs (v,e) -> SCC l e -> sub e `thenUs` \e -> -> returnUs (SCC l e) -> -> Coerce _ _ _ -> panic "DefUtils.subst:Coerce" - -> substAtom (VarArg v) = -> substArg v `thenUs` \v -> -> returnUs (VarArg v) -> substAtom (LitArg l) = -> returnUs (LitArg l) -- XXX - -> substArg (DefArgExpr e) = -> sub e `thenUs` \e -> -> returnUs (DefArgExpr e) -> substArg e@(Label _ _) = -> panic "DefExpr(substArg): Label _ _" -> substArg e@(DefArgVar v) = -- XXX -> case lookupIdEnv p' v of -> Just e -> rebindExpr e `thenUs` \e -> -> returnUs (DefArgExpr e) -> Nothing -> returnUs e - -> substCaseAlts (AlgAlts as def) = -> mapUs substAlgAlt as `thenUs` \as -> -> substDefault def `thenUs` \def -> -> returnUs (AlgAlts as def) -> substCaseAlts (PrimAlts as def) = -> mapUs substPrimAlt as `thenUs` \as -> -> substDefault def `thenUs` \def -> -> returnUs (PrimAlts as def) - -> substAlgAlt (c, vs, e) = -> sub e `thenUs` \e -> -> returnUs (c, vs, e) -> substPrimAlt (l, e) = -> sub e `thenUs` \e -> -> returnUs (l, e) - -> substDefault NoDefault = -> returnUs NoDefault -> substDefault (BindDefault v e) = -> sub e `thenUs` \e -> -> returnUs (BindDefault v e) - ------------------------------------------------------------------------------ - -> union [] ys = ys -> union (x:xs) ys -> | x `is_elem` ys = union xs ys -> | otherwise = x : union xs ys -> where { is_elem = isIn "union(deforest)" } diff --git a/ghc/compiler/deforest/Deforest.lhs b/ghc/compiler/deforest/Deforest.lhs deleted file mode 100644 index 804ba2b..0000000 --- a/ghc/compiler/deforest/Deforest.lhs +++ /dev/null @@ -1,138 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 -% -\section[Deforest]{Top level deforestation module} - ->#include "HsVersions.h" -> -> module Deforest ( -> deforestProgram -> ) where - -> import Core2Def -> import Def2Core -> import DefUtils -> import DefSyn -> import DefExpr -> import Cyclic -> import TreelessForm ->#ifdef __HBC__ -> import Trace ->#endif - -> import CmdLineOpts ( GlobalSwitch, SwitchResult ) -> import CoreSyn -> import Id ( Id ) -> import IdInfo -> import Outputable -> import SimplEnv ( SYN_IE(SwitchChecker) ) -> import UniqSupply -> import Util - -> -- tmp, for traces -> import Pretty - -> -- stub (ToDo) -> domIdEnv = panic "Deforest: domIdEnv" - -> deforestProgram -> :: SwitchChecker GlobalSwitch{-maybe-} -> -> [CoreBinding] -> -> UniqSupply -> -> [CoreBinding] -> -> deforestProgram sw prog uq = -> let -> def_program = core2def sw prog -> out_program = ( -> defProg sw nullIdEnv def_program `thenUs` \prog -> -> def2core prog) -> uq -> in -> out_program - -We have to collect all the unfoldings (functions that were annotated -with DEFOREST) and pass them in an environment to subsequent calls of -the transformer. - -Recursive functions are first transformed by the deforester. If the -function is annotated as deforestable, then it is converted to -treeless form for unfolding later on. - -Also converting non-recursive functions that are annotated with -{-# DEFOREST #-} now. Probably don't need to convert these to treeless -form: just the inner recursive bindings they contain. eg: - -repeat = \x -> letrec xs = x:xs in xs - -is non-recursive, but we want to unfold it and annotate the binding -for xs as unfoldable, too. - -> defProg -> :: SwitchChecker GlobalSwitch{-maybe-} -> -> IdEnv DefExpr -> -> [DefBinding] -> -> UniqSM [DefBinding] -> -> defProg sw p [] = returnUs [] -> -> defProg sw p (NonRec v e : bs) = -> trace ("Processing: `" ++ -> show (ppr PprDebug v) ++ "'\n") ( -> tran sw p nullTyVarEnv e [] `thenUs` \e -> -> mkLoops e `thenUs` \(extracted,e) -> -> let e' = mkDefLetrec extracted e in -> ( -> if deforestable v then -> let (vs,es) = unzip extracted in -> convertToTreelessForm sw e `thenUs` \e -> -> mapUs (convertToTreelessForm sw) es `thenUs` \es -> -> defProg sw (growIdEnvList p ((v,e):zip vs es)) bs -> else -> defProg sw p bs -> ) `thenUs` \bs -> -> returnUs (NonRec v e' : bs) -> ) -> -> defProg sw p (Rec bs : bs') = -> mapUs (defRecBind sw p) bs `thenUs` \res -> -> let -> (resid, unfold) = unzip res -> p' = growIdEnvList p (concat unfold) -> in -> defProg sw p' bs' `thenUs` \bs' -> -> returnUs (Rec resid: bs') - - -> defRecBind -> :: SwitchChecker GlobalSwitch{-maybe-} -> -> IdEnv DefExpr -> -> (Id,DefExpr) -> -> UniqSM ((Id,DefExpr),[(Id,DefExpr)]) -> -> defRecBind sw p (v,e) = -> trace ("Processing: `" ++ -> show (ppr PprDebug v) ++ "'\n") ( -> tran sw p nullTyVarEnv e [] `thenUs` \e' -> -> mkLoops e' `thenUs` \(bs,e') -> -> let e'' = mkDefLetrec bs e' in -> -> d2c e'' `thenUs` \core_e -> -> let showBind (v,e) = show (ppr PprDebug v) ++ -> "=\n" ++ show (ppr PprDebug e) ++ "\n" -> in -> trace ("Extracting from `" ++ -> show (ppr PprDebug v) ++ "'\n" -> ++ "{ result:\n" ++ showBind (v,core_e) ++ "}\n") $ -> -> if deforestable v -> then -> let (vs,es) = unzip bs in -> convertToTreelessForm sw e' `thenUs` \e' -> -> mapUs (convertToTreelessForm sw) es `thenUs` \es -> -> returnUs ((v,e''),(v,e'):zip vs es) -> else -> trace (show (length bs)) ( -> returnUs ((v,e''),[]) -> ) -> ) diff --git a/ghc/compiler/deforest/TreelessForm.lhs b/ghc/compiler/deforest/TreelessForm.lhs deleted file mode 100644 index 87359e6..0000000 --- a/ghc/compiler/deforest/TreelessForm.lhs +++ /dev/null @@ -1,187 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 -% -\section[TreelessForm]{Convert Arbitrary expressions into treeless form} - ->#include "HsVersions.h" -> -> module TreelessForm ( -> convertToTreelessForm -> ) where -> -> import DefSyn -> import DefUtils - -> import CmdLineOpts ( SwitchResult, switchIsOn ) -> import CoreUtils ( coreExprType ) -> import Id ( replaceIdInfo, getIdInfo ) -> import IdInfo -> import Outputable -> import SimplEnv ( SYN_IE(SwitchChecker) ) -> import UniqSupply -> import Util - -> -- tmp -> import Pretty -> import Def2Core - -Very simplistic approach to begin with: - -case e of {...} ====> let x = e in case x of {...} -x e1 ... en ====> let x1 = e1 in ... let xn = en in (x x1 ... xn) - -ToDo: make this better. - -> convertToTreelessForm -> :: SwitchChecker sw -> -> DefExpr -> -> UniqSM DefExpr -> -> convertToTreelessForm sw e -> = convExpr e -> -> convExpr -> :: DefExpr -> -> UniqSM DefExpr - -> convExpr e = case e of -> -> Var (DefArgExpr e) -> -> panic "TreelessForm(substTy): Var (DefArgExpr _)" -> -> Var (Label l e) -> -> panic "TreelessForm(substTy): Var (Label _ _)" -> -> Var (DefArgVar id) -> returnUs e -> -> Lit l -> returnUs e -> -> Con c ts es -> -> mapUs convAtom es `thenUs` \es -> -> returnUs (Con c ts es) -> -> Prim op ts es -> -> mapUs convAtom es `thenUs` \es -> -> returnUs (Prim op ts es) -> -> Lam vs e -> -> convExpr e `thenUs` \e -> -> returnUs (Lam vs e) -> -> CoTyLam alpha e -> -> convExpr e `thenUs` \e -> -> returnUs (CoTyLam alpha e) -> -> App e v -> -> convExpr e `thenUs` \e -> -> case v of -> LitArg l -> returnUs (App e v) -> VarArg v' -> -> case v' of -> DefArgVar _ -> panic "TreelessForm(convExpr): DefArgVar" -> DefArgExpr (Var (DefArgVar id)) -> | (not.deforestable) id -> -> returnUs (App e v) -> DefArgExpr e' -> -> newLet e' (\id -> App e (VarArg -> (DefArgExpr id))) -> -> CoTyApp e ty -> -> convExpr e `thenUs` \e -> -> returnUs (CoTyApp e ty) -> -> Case e ps -> -> convCaseAlts ps `thenUs` \ps -> -> case e of -> Var (DefArgVar id) | (not.deforestable) id -> -> returnUs (Case e ps) -> Prim op ts es -> returnUs (Case e ps) -> _ -> d2c e `thenUs` \e' -> -> newLet e (\v -> Case v ps) -> -> Let (NonRec id e) e' -> -> convExpr e `thenUs` \e -> -> convExpr e' `thenUs` \e' -> -> returnUs (Let (NonRec id e) e') -> -> Let (Rec bs) e -> ->-- convRecBinds bs e `thenUs` \(bs,e) -> ->-- returnUs (Let (Rec bs) e) -> convExpr e `thenUs` \e -> -> mapUs convRecBind bs `thenUs` \bs -> -> returnUs (Let (Rec bs) e) -> where -> convRecBind (v,e) = -> convExpr e `thenUs` \e -> -> returnUs (v,e) -> -> SCC l e -> -> convExpr e `thenUs` \e -> -> returnUs (SCC l e) -> -> Coerce _ _ _ -> panic "TreelessForm:convExpr:Coerce" - -Mark all the recursive functions as deforestable. Might as well, -since they will be in treeless form anyway. This helps to cope with -overloaded functions, where the compiler earlier lifts out the -dictionary deconstruction. - -> convRecBinds bs e = -> convExpr e `thenUs` \e' -> -> mapUs convExpr es `thenUs` \es' -> -> mapUs (subst s) es' `thenUs` \es'' -> -> subst s e' `thenUs` \e'' -> -> returnUs (zip vs' es', e') -> where -> (vs,es) = unzip bs -> vs' = map mkDeforestable vs -> s = zip vs (map (Var . DefArgVar) vs') -> mkDeforestable v = addIdDeforestInfo v DoDeforest - -> convAtom :: DefAtom -> UniqSM DefAtom -> -> convAtom (VarArg v) = -> convArg v `thenUs` \v -> -> returnUs (VarArg v) -> convAtom (LitArg l) = -> returnUs (LitArg l) -- XXX - -> convArg :: DefBindee -> UniqSM DefBindee -> -> convArg (DefArgExpr e) = -> convExpr e `thenUs` \e -> -> returnUs (DefArgExpr e) -> convArg e@(Label _ _) = -> panic "TreelessForm(convArg): Label _ _" -> convArg e@(DefArgVar id) = -> panic "TreelessForm(convArg): DefArgVar _ _" - -> convCaseAlts :: DefCaseAlternatives -> UniqSM DefCaseAlternatives -> -> convCaseAlts (AlgAlts as def) = -> mapUs convAlgAlt as `thenUs` \as -> -> convDefault def `thenUs` \def -> -> returnUs (AlgAlts as def) -> convCaseAlts (PrimAlts as def) = -> mapUs convPrimAlt as `thenUs` \as -> -> convDefault def `thenUs` \def -> -> returnUs (PrimAlts as def) - -> convAlgAlt (c, vs, e) = -> convExpr e `thenUs` \e -> -> returnUs (c, vs, e) -> convPrimAlt (l, e) = -> convExpr e `thenUs` \e -> -> returnUs (l, e) - -> convDefault NoDefault = -> returnUs NoDefault -> convDefault (BindDefault id e) = -> convExpr e `thenUs` \e -> -> returnUs (BindDefault id e) - -> newLet :: DefExpr -> (DefExpr -> DefExpr) -> UniqSM DefExpr -> newLet e body = -> d2c e `thenUs` \core_expr -> -> newDefId (coreExprType core_expr) `thenUs` \new_id -> -> returnUs (Let (NonRec new_id e) (body (Var (DefArgVar new_id)))) -- 1.7.10.4