I was *sure* I'd removed these before...
+++ /dev/null
-%
-% (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
+++ /dev/null
-%
-% (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
+++ /dev/null
-%
-% (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))
+++ /dev/null
-%
-% (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
+++ /dev/null
-%
-% (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)
+++ /dev/null
-%
-% (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)" }
+++ /dev/null
-%
-% (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''),[])
-> )
-> )
+++ /dev/null
-%
-% (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))))
projects / ghc-hetmet.git / commitdiff