%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[DefUtils]{Miscellaneous Utility functions}
> atom2expr, newDefId, newTmpId, deforestable, foldrSUs,
> mkDefLetrec, subst, freeTyVars, union, consistent, RenameResult(..),
> isArgId
-> )
+> )
> where
> import DefSyn
> import Trace
>#endif
-> import AbsUniType ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy,
+> import Type ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy,
> extractTyVarsFromTy, TyVar, SigmaType(..)
> IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
> )
-> import BasicLit ( BasicLit ) -- for Eq BasicLit
+> import Literal ( Literal ) -- for Eq Literal
> import CoreSyn
> import Id ( mkIdWithNewUniq, mkSysLocal, applyTypeEnvToId,
-> getIdInfo, toplevelishId, getIdUniType, Id )
-> import IdEnv
+> getIdInfo, toplevelishId, idType, Id )
> import IdInfo
> import Outputable
> import Pretty
-> import PrimOps ( PrimOp ) -- for Eq PrimOp
-> import SplitUniq
+> import PrimOp ( PrimOp ) -- for Eq PrimOp
+> import UniqSupply
> import SrcLoc ( mkUnknownSrcLoc )
-> import TyVarEnv
> import Util
-----------------------------------------------------------------------------
> strip :: DefExpr -> DefExpr
> strip e' = case e' of
-> CoVar (DefArgExpr e) -> panic "DefUtils(strip): CoVar (DefExpr _)"
-> CoVar (Label l e) -> l
-> CoVar (DefArgVar v) -> e'
-> CoLit l -> e'
-> CoCon c ts es -> CoCon c ts (map stripAtom es)
-> CoPrim op ts es -> CoPrim op ts (map stripAtom es)
-> CoLam vs e -> CoLam vs (strip e)
+> 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)
-> CoApp e v -> CoApp (strip e) (stripAtom v)
+> App e v -> App (strip e) (stripAtom v)
> CoTyApp e t -> CoTyApp (strip e) t
-> CoCase e ps -> CoCase (strip e) (stripCaseAlts ps)
-> CoLet (CoNonRec v e) e' -> CoLet (CoNonRec v (strip e)) (strip e')
-> CoLet (CoRec bs) e ->
-> CoLet (CoRec [ (v, strip e) | (v,e) <- bs ]) (strip e)
-> CoSCC l e -> CoSCC l (strip e)
+> 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)
> stripAtom :: DefAtom -> DefAtom
-> stripAtom (CoVarAtom v) = CoVarAtom (stripArg v)
-> stripAtom (CoLitAtom l) = CoLitAtom l -- XXX
+> 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 (CoAlgAlts as def)
-> = CoAlgAlts (map stripAlgAlt as) (stripDefault def)
-> stripCaseAlts (CoPrimAlts as def)
-> = CoPrimAlts (map stripPrimAlt as) (stripDefault def)
+> 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 CoNoDefault = CoNoDefault
-> stripDefault (CoBindDefault v e) = CoBindDefault v (strip e)
+> stripDefault NoDefault = NoDefault
+> stripDefault (BindDefault v e) = BindDefault v (strip e)
-----------------------------------------------------------------------------
\subsection{Free Variables}
> freeVars :: DefExpr -> [Id]
> freeVars e = free e []
-> where
+> where
> free e fvs = case e of
-> CoVar (DefArgExpr e) ->
-> panic "DefUtils(free): CoVar (DefExpr _)"
-> CoVar (Label l e) -> free l fvs
-> CoVar (DefArgVar v)
+> 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)" }
-> CoLit l -> fvs
-> CoCon c ts es -> foldr freeAtom fvs es
-> CoPrim op ts es -> foldr freeAtom fvs es
-> CoLam vs e -> free' vs (free e fvs)
+> 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
-> CoApp e v -> free e (freeAtom v fvs)
+> App e v -> free e (freeAtom v fvs)
> CoTyApp e t -> free e fvs
-> CoCase e ps -> free e (freeCaseAlts ps fvs)
-> CoLet (CoNonRec v e) e' -> free e (free' [v] (free e' fvs))
-> CoLet (CoRec bs) e -> free' vs (foldr free (free e fvs) es)
+> 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
-> CoSCC l e -> free e fvs
+> SCC l e -> free e fvs
> free' :: [Id] -> [Id] -> [Id]
> free' vs fvs = filter (\x -> notElem x vs) fvs
-> freeAtom (CoVarAtom (DefArgExpr e)) fvs = free e fvs
-> freeAtom (CoVarAtom (Label l e)) fvs
-> = panic "DefUtils(free): CoVarAtom (Label _ _)"
-> freeAtom (CoVarAtom (DefArgVar v)) fvs
-> = panic "DefUtils(free): CoVarAtom (DefArgVar _ _)"
-> freeAtom (CoLitAtom l) fvs = 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 (CoAlgAlts as def) fvs
+> freeCaseAlts (AlgAlts as def) fvs
> = foldr freeAlgAlt (freeDefault def fvs) as
-> freeCaseAlts (CoPrimAlts as def) fvs
+> 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 CoNoDefault fvs = fvs
-> freeDefault (CoBindDefault v e) fvs = free' [v] (free e fvs)
+> freeDefault NoDefault fvs = fvs
+> freeDefault (BindDefault v e) fvs = free' [v] (free e fvs)
-----------------------------------------------------------------------------
\subsection{Free Type Variables}
> freeTyVars e = free e []
> where
> free e tvs = case e of
-> CoVar (DefArgExpr e) ->
-> panic "DefUtils(freeVars): CoVar (DefExpr _)"
-> CoVar (Label l e) -> free l tvs
-> CoVar (DefArgVar id) -> freeId id tvs
-> CoLit l -> tvs
-> CoCon c ts es -> foldr freeTy (foldr freeAtom tvs es) ts
-> CoPrim op ts es -> foldr freeTy (foldr freeAtom tvs es) ts
-> CoLam vs e -> foldr freeId (free e tvs) vs
+> 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)
-> CoApp e v -> free e (freeAtom v tvs)
+> App e v -> free e (freeAtom v tvs)
> CoTyApp e t -> free e (freeTy t tvs)
-> CoCase e ps -> free e (freeCaseAlts ps tvs)
-> CoLet (CoNonRec v e) e' -> free e (freeId v (free e' tvs))
-> CoLet (CoRec bs) e -> foldr freeBind (free e tvs) bs
-> CoSCC l e -> free e tvs
->
-> freeId id tvs = extractTyVarsFromTy (getIdUniType id) `union` 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
+>
+> freeId id tvs = extractTyVarsFromTy (idType id) `union` tvs
> freeTy t tvs = extractTyVarsFromTy t `union` tvs
> freeBind (v,e) tvs = freeId v (free e tvs)
-
-> freeAtom (CoVarAtom (DefArgExpr e)) tvs = free e tvs
-> freeAtom (CoVarAtom (Label l e)) tvs
-> = panic "DefUtils(freeVars): CoVarAtom (Label _ _)"
-> freeAtom (CoVarAtom (DefArgVar v)) tvs
-> = panic "DefUtils(freeVars): CoVarAtom (DefArgVar _ _)"
-> freeAtom (CoLitAtom l) tvs = tvs -- XXX
-
-> freeCaseAlts (CoAlgAlts as def) 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 (CoPrimAlts as def) tvs
+> 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 CoNoDefault tvs = tvs
-> freeDefault (CoBindDefault v e) tvs = freeId v (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 -> SUniqSM DefExpr
+> rebindExpr :: DefExpr -> UniqSM DefExpr
> rebindExpr e = uniqueExpr nullIdEnv nullTyVarEnv e
-> uniqueExpr :: IdEnv Id -> TypeEnv -> DefExpr -> SUniqSM DefExpr
+> uniqueExpr :: IdEnv Id -> TypeEnv -> DefExpr -> UniqSM DefExpr
> uniqueExpr p t e =
> case e of
-> CoVar (DefArgVar v) ->
-> returnSUs (CoVar (DefArgVar (lookup v p)))
->
-> CoVar (Label l e) ->
-> uniqueExpr p t l `thenSUs` \l ->
-> uniqueExpr p t e `thenSUs` \e ->
-> returnSUs (mkLabel l e)
->
-> CoVar (DefArgExpr _) ->
-> panic "DefUtils(uniqueExpr): CoVar(DefArgExpr _)"
->
-> CoLit l ->
-> returnSUs e
->
-> CoCon c ts es ->
-> mapSUs (uniqueAtom p t) es `thenSUs` \es ->
-> returnSUs (CoCon c (map (applyTypeEnvToTy t) ts) es)
->
-> CoPrim op ts es ->
-> mapSUs (uniqueAtom p t) es `thenSUs` \es ->
-> returnSUs (CoPrim op (map (applyTypeEnvToTy t) ts) es)
->
-> CoLam vs e ->
-> mapSUs (newVar t) vs `thenSUs` \vs' ->
-> uniqueExpr (growIdEnvList p (zip vs vs')) t e `thenSUs` \e ->
-> returnSUs (CoLam vs' e)
->
+> 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 ->
-> getSUnique `thenSUs` \u ->
+> getUnique `thenUs` \u ->
> let v' = cloneTyVar v u
> t' = addOneToTyVarEnv t v (mkTyVarTy v') in
-> uniqueExpr p t' e `thenSUs` \e ->
-> returnSUs (CoTyLam v' e)
->
-> CoApp e v ->
-> uniqueExpr p t e `thenSUs` \e ->
-> uniqueAtom p t v `thenSUs` \v ->
-> returnSUs (CoApp e v)
->
+> 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 `thenSUs` \e ->
-> returnSUs (mkCoTyApp e (applyTypeEnvToTy t ty))
->
-> CoCase e alts ->
-> uniqueExpr p t e `thenSUs` \e ->
-> uniqueAlts alts `thenSUs` \alts ->
-> returnSUs (CoCase e alts)
+> 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 (CoAlgAlts as d) =
-> mapSUs uniqueAlgAlt as `thenSUs` \as ->
-> uniqueDefault d `thenSUs` \d ->
-> returnSUs (CoAlgAlts as d)
-> uniqueAlts (CoPrimAlts as d) =
-> mapSUs uniquePrimAlt as `thenSUs` \as ->
-> uniqueDefault d `thenSUs` \d ->
-> returnSUs (CoPrimAlts as d)
->
-> uniqueAlgAlt (c, vs, e) =
-> mapSUs (newVar t) vs `thenSUs` \vs' ->
-> uniqueExpr (growIdEnvList p (zip vs vs')) t e
-> `thenSUs` \e ->
-> returnSUs (c, vs', e)
+> 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 `thenSUs` \e ->
-> returnSUs (l, e)
->
-> uniqueDefault CoNoDefault = returnSUs CoNoDefault
-> uniqueDefault (CoBindDefault v e) =
-> newVar t v `thenSUs` \v' ->
-> uniqueExpr (addOneToIdEnv p v v') t e `thenSUs` \e ->
-> returnSUs (CoBindDefault v' e)
->
-> CoLet (CoNonRec v e) e' ->
-> uniqueExpr p t e `thenSUs` \e ->
-> newVar t v `thenSUs` \v' ->
-> uniqueExpr (addOneToIdEnv p v v') t e' `thenSUs` \e' ->
-> returnSUs (CoLet (CoNonRec v' e) e')
->
-> CoLet (CoRec ds) 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
-> mapSUs (newVar t) vs `thenSUs` \vs' ->
+> mapUs (newVar t) vs `thenUs` \vs' ->
> let p' = growIdEnvList p (zip vs vs') in
-> mapSUs (uniqueExpr p' t) es `thenSUs` \es ->
-> uniqueExpr p' t e `thenSUs` \e ->
-> returnSUs (CoLet (CoRec (zip vs' es)) e)
->
-> CoSCC l e ->
-> uniqueExpr p t e `thenSUs` \e ->
-> returnSUs (CoSCC l e)
->
->
-> uniqueAtom :: IdEnv Id -> TypeEnv -> DefAtom -> SUniqSM DefAtom
-> uniqueAtom p t (CoLitAtom l) = returnSUs (CoLitAtom l) -- XXX
-> uniqueAtom p t (CoVarAtom v) =
-> uniqueArg p t v `thenSUs` \v ->
-> returnSUs (CoVarAtom v)
->
+> 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)
+>
+>
+> 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 `thenSUs` \e ->
-> returnSUs (DefArgExpr e)
+> uniqueExpr p t e `thenUs` \e ->
+> returnUs (DefArgExpr e)
> uniqueArg p t (Label l e) =
> panic "DefUtils(uniqueArg): Label _ _"
> Nothing -> id
> Just new_id -> new_id
-> newVar :: TypeEnv -> Id -> SUniqSM Id
-> newVar t id =
-> getSUnique `thenSUs` \u ->
-> returnSUs (mkIdWithNewUniq (applyTypeEnvToId t id) u)
+> newVar :: TypeEnv -> Id -> UniqSM Id
+> newVar t id =
+> getUnique `thenUs` \u ->
+> returnUs (mkIdWithNewUniq (applyTypeEnvToId t id) u)
-----------------------------------------------------------------------------
\subsection{Detecting Renamings}
We only allow renaming of sysLocal ids - ie. not top-level, imported
or otherwise global ids.
-> data RenameResult
+> data RenameResult
> = NotRenaming
> | IsRenaming [(Id,Id)]
> | InconsistentRenaming [(Id,Id)]
-> renameExprs :: DefExpr -> DefExpr -> SUniqSM RenameResult
-> renameExprs u u' =
+> renameExprs :: DefExpr -> DefExpr -> UniqSM RenameResult
+> renameExprs u u' =
> case ren u u' of
-> [] -> returnSUs NotRenaming
-> [r] -> if not (consistent r) then
-> d2c (strip u) `thenSUs` \u ->
-> d2c (strip u') `thenSUs` \u' ->
+> [] -> returnUs NotRenaming
+> [r] -> if not (consistent r) then
+> d2c (strip u) `thenUs` \u ->
+> d2c (strip u') `thenUs` \u' ->
> trace ("failed consistency check:\n" ++
> ppShow 80 (ppr PprDebug u) ++ "\n" ++
> ppShow 80 (ppr PprDebug u'))
-> (returnSUs (InconsistentRenaming r))
-> else
-> trace "Renaming!" (returnSUs (IsRenaming r))
+> (returnUs (InconsistentRenaming r))
+> else
+> trace "Renaming!" (returnUs (IsRenaming r))
> _ -> panic "DefUtils(renameExprs)"
Check that we have a consistent renaming. A renaming is consistent if
> checkConsistency :: [(Id,Id)] -> [[(Id,Id)]] -> [[(Id,Id)]]
> checkConsistency bound free = [ r' | r <- free, r' <- check r ]
-> where
+> where
> check r | they're_consistent = [frees]
> | otherwise = []
-> where
+> where
> (bounds,frees) = partition (\(a,b) -> a `elem` lbound) r
> (lbound,rbound) = unzip bound
> they're_consistent = consistent (bound ++ bounds)
comparing the expressions.
> ren :: DefExpr -> DefExpr -> [[(Id,Id)]]
->
+>
> -- renaming or identical cases --
->
+>
>
> -- same variable, no renaming
-> ren (CoVar (DefArgVar x)) t@(CoVar (DefArgVar y))
+> 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 (CoVar (DefArgVar x)) t
+> ren (Var (DefArgVar x)) t
> | okToRename x && all (not. deforestable) (freeVars t)
> = [[(x,t)]]
> -}
-> ren (CoLit l) (CoLit l') | l == l'
+> ren (Lit l) (Lit l') | l == l'
> = [[]]
-> ren (CoCon c ts es) (CoCon c' ts' es') | c == c'
+> ren (Con c ts es) (Con c' ts' es') | c == c'
> = foldr (....) [[]] (zipWith renAtom es es')
-> ren (CoPrim op ts es) (CoPrim op' ts' es') | op == op'
+> ren (Prim op ts es) (Prim op' ts' es') | op == op'
> = foldr (....) [[]] (zipWith renAtom es es')
-> ren (CoLam vs e) (CoLam vs' e')
+> 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 (CoApp e v) (CoApp e' v')
+> 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 (CoCase e alts) (CoCase e' alts')
+> ren (Case e alts) (Case e' alts')
> = ren e e' .... renAlts alts alts'
-> ren (CoLet (CoNonRec v a) b) (CoLet (CoNonRec v' a') b')
+> ren (Let (NonRec v a) b) (Let (NonRec v' a') b')
> = ren a a' .... (checkConsistency [(v,v')] (ren b b'))
-> ren (CoLet (CoRec ds) e) (CoLet (CoRec ds') e')
-> = checkConsistency (zip vs vs')
+> 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 (CoVar (Label l e)) e' = ren l e'
-> ren e (CoVar (Label l e')) = ren e l
+>
+> ren (Var (Label l e)) e' = ren l e'
+> ren e (Var (Label l e')) = ren e l
>
> -- error cases --
->
-> ren (CoVar (DefArgExpr _)) _
-> = panic "DefUtils(ren): CoVar (DefArgExpr _)"
-> ren _ (CoVar (DefArgExpr _))
-> = panic "DefUtils(ren): CoVar (DefArgExpr _)"
->
+>
+> ren (Var (DefArgExpr _)) _
+> = panic "DefUtils(ren): Var (DefArgExpr _)"
+> ren _ (Var (DefArgExpr _))
+> = panic "DefUtils(ren): Var (DefArgExpr _)"
+>
> -- default case --
->
-> ren _ _ = []
+>
+> ren _ _ = []
Rename atoms.
-> renAtom (CoVarAtom (DefArgExpr e)) (CoVarAtom (DefArgExpr e'))
+> renAtom (VarArg (DefArgExpr e)) (VarArg (DefArgExpr e'))
> = ren e e'
> -- XXX shouldn't need the next two
-> renAtom (CoLitAtom l) (CoLitAtom l') | l == l' = [[]]
-> renAtom (CoVarAtom (DefArgVar v)) _ =
-> panic "DefUtils(renAtom): CoVarAtom (DefArgVar _ _)"
-> renAtom _ (CoVarAtom (DefArgVar v)) =
-> panic "DefUtils(renAtom): CoVarAtom (DefArgVar _ _)"
-> renAtom (CoVarAtom (Label _ _)) _ =
-> panic "DefUtils(renAtom): CoVarAtom (Label _ _)"
-> renAtom e (CoVarAtom (Label l e')) =
-> panic "DefUtils(renAtom): CoVarAtom (Label _ _)"
->
+> 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 (CoAlgAlts as dflt) (CoAlgAlts as' dflt')
+> renAlts (AlgAlts as dflt) (AlgAlts as' dflt')
> = foldr (....) [[]] (zipWith renAlgAlt as as') .... renDefault dflt dflt'
-> renAlts (CoPrimAlts as dflt) (CoPrimAlts as' 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'
+>
+> 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 CoNoDefault CoNoDefault = [[]]
-> renDefault (CoBindDefault v e) (CoBindDefault v' e')
+> renDefault NoDefault NoDefault = [[]]
+> renDefault (BindDefault v e) (BindDefault v' e')
> = checkConsistency [(v,v')] (ren e e')
-----------------------------------------------------------------------------
> atom2expr :: DefAtom -> DefExpr
-> atom2expr (CoVarAtom (DefArgExpr e)) = e
-> atom2expr (CoVarAtom (Label l e)) = mkLabel l e
+> atom2expr (VarArg (DefArgExpr e)) = e
+> atom2expr (VarArg (Label l e)) = mkLabel l e
> -- XXX next two should be illegal
-> atom2expr (CoLitAtom l) = CoLit l
-> atom2expr (CoVarAtom (DefArgVar v)) =
-> panic "DefUtils(atom2expr): CoVarAtom (DefArgVar _)"
+> atom2expr (LitArg l) = Lit l
+> atom2expr (VarArg (DefArgVar v)) =
+> panic "DefUtils(atom2expr): VarArg (DefArgVar _)"
-> expr2atom = CoVarAtom . DefArgExpr
+> expr2atom = VarArg . DefArgExpr
-----------------------------------------------------------------------------
Grab a new Id and tag it as coming from the Deforester.
-> newDefId :: UniType -> SUniqSM Id
-> newDefId t =
-> getSUnique `thenSUs` \u ->
-> returnSUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc)
+> newDefId :: Type -> UniqSM Id
+> newDefId t =
+> getUnique `thenUs` \u ->
+> returnUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc)
-> newTmpId :: UniType -> SUniqSM Id
+> newTmpId :: Type -> UniqSM Id
> newTmpId t =
-> getSUnique `thenSUs` \u ->
-> returnSUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc)
+> getUnique `thenUs` \u ->
+> returnUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc)
-----------------------------------------------------------------------------
Check whether an Id was given a `DEFOREST' annotation by the programmer.
-----------------------------------------------------------------------------
Filter for free variables to abstract from new functions.
-> isArgId id
-> = (not . deforestable) id
-> && (not . toplevelishId) id
+> isArgId id
+> = (not . deforestable) id
+> && (not . toplevelishId) id
-----------------------------------------------------------------------------
-> foldrSUs f c [] = returnSUs c
+> foldrSUs f c [] = returnUs c
> foldrSUs f c (x:xs)
-> = foldrSUs f c xs `thenSUs` \xs' ->
+> = foldrSUs f c xs `thenUs` \xs' ->
> f x xs'
-----------------------------------------------------------------------------
> mkDefLetrec [] e = e
-> mkDefLetrec bs e = CoLet (CoRec bs) e
+> mkDefLetrec bs e = Let (Rec bs) e
-----------------------------------------------------------------------------
Substitutions.
> subst :: [(Id,DefExpr)]
> -> DefExpr
-> -> SUniqSM DefExpr
+> -> UniqSM DefExpr
> subst p e' = sub e'
> where
> p' = mkIdEnv p
> sub e' = case e' of
-> CoVar (DefArgExpr e) -> panic "DefExpr(sub): CoVar (DefArgExpr _)"
-> CoVar (Label l e) -> panic "DefExpr(sub): CoVar (Label _ _)"
-> CoVar (DefArgVar v) ->
+> 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 `thenSUs` \e -> returnSUs e
-> Nothing -> returnSUs e'
-> CoLit l -> returnSUs e'
-> CoCon c ts es -> mapSUs substAtom es `thenSUs` \es ->
-> returnSUs (CoCon c ts es)
-> CoPrim op ts es -> mapSUs substAtom es `thenSUs` \es ->
-> returnSUs (CoPrim op ts es)
-> CoLam vs e -> sub e `thenSUs` \e ->
-> returnSUs (CoLam vs e)
-> CoTyLam alpha e -> sub e `thenSUs` \e ->
-> returnSUs (CoTyLam alpha e)
-> CoApp e v -> sub e `thenSUs` \e ->
-> substAtom v `thenSUs` \v ->
-> returnSUs (CoApp e v)
-> CoTyApp e t -> sub e `thenSUs` \e ->
-> returnSUs (CoTyApp e t)
-> CoCase e ps -> sub e `thenSUs` \e ->
-> substCaseAlts ps `thenSUs` \ps ->
-> returnSUs (CoCase e ps)
-> CoLet (CoNonRec v e) e'
-> -> sub e `thenSUs` \e ->
-> sub e' `thenSUs` \e' ->
-> returnSUs (CoLet (CoNonRec v e) e')
-> CoLet (CoRec bs) e -> sub e `thenSUs` \e ->
-> mapSUs substBind bs `thenSUs` \bs ->
-> returnSUs (CoLet (CoRec bs) e)
+> 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 `thenSUs` \e ->
-> returnSUs (v,e)
-> CoSCC l e -> sub e `thenSUs` \e ->
-> returnSUs (CoSCC l e)
-
-> substAtom (CoVarAtom v) =
-> substArg v `thenSUs` \v ->
-> returnSUs (CoVarAtom v)
-> substAtom (CoLitAtom l) =
-> returnSUs (CoLitAtom l) -- XXX
-
-> substArg (DefArgExpr e) =
-> sub e `thenSUs` \e ->
-> returnSUs (DefArgExpr e)
-> substArg e@(Label _ _) =
+> substBind (v,e) =
+> sub e `thenUs` \e ->
+> returnUs (v,e)
+> SCC l e -> sub e `thenUs` \e ->
+> returnUs (SCC l e)
+
+> 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 `thenSUs` \e ->
-> returnSUs (DefArgExpr e)
-> Nothing -> returnSUs e
-
-> substCaseAlts (CoAlgAlts as def) =
-> mapSUs substAlgAlt as `thenSUs` \as ->
-> substDefault def `thenSUs` \def ->
-> returnSUs (CoAlgAlts as def)
-> substCaseAlts (CoPrimAlts as def) =
-> mapSUs substPrimAlt as `thenSUs` \as ->
-> substDefault def `thenSUs` \def ->
-> returnSUs (CoPrimAlts as def)
-
-> substAlgAlt (c, vs, e) =
-> sub e `thenSUs` \e ->
-> returnSUs (c, vs, e)
-> substPrimAlt (l, e) =
-> sub e `thenSUs` \e ->
-> returnSUs (l, e)
-
-> substDefault CoNoDefault =
-> returnSUs CoNoDefault
-> substDefault (CoBindDefault v e) =
-> sub e `thenSUs` \e ->
-> returnSUs (CoBindDefault v e)
+> 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
+> union (x:xs) ys
> | x `is_elem` ys = union xs ys
> | otherwise = x : union xs ys
> where { is_elem = isIn "union(deforest)" }
projects / ghc-hetmet.git / blobdiff