diff options
Diffstat (limited to 'ghc/compiler/deforest/DefUtils.lhs')
| -rw-r--r-- | ghc/compiler/deforest/DefUtils.lhs | 648 |
1 files changed, 323 insertions, 325 deletions
diff --git a/ghc/compiler/deforest/DefUtils.lhs b/ghc/compiler/deforest/DefUtils.lhs index 81752f9b2a..54f8eeb118 100644 --- a/ghc/compiler/deforest/DefUtils.lhs +++ b/ghc/compiler/deforest/DefUtils.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[DefUtils]{Miscellaneous Utility functions} @@ -10,7 +10,7 @@ > atom2expr, newDefId, newTmpId, deforestable, foldrSUs, > mkDefLetrec, subst, freeTyVars, union, consistent, RenameResult(..), > isArgId -> ) +> ) > where > import DefSyn @@ -20,22 +20,20 @@ > 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 ----------------------------------------------------------------------------- @@ -48,41 +46,41 @@ its left hand side. The result is a term with no labels. > 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} @@ -94,48 +92,48 @@ but l is guranteed to be finite so we choose that one. > 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} @@ -144,43 +142,43 @@ but l is guranteed to be finite so we choose that one. > 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} @@ -188,114 +186,114 @@ but l is guranteed to be finite so we choose that one. 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 _ _" @@ -309,10 +307,10 @@ expression as a whole (?) > 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} @@ -326,24 +324,24 @@ expression). 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 @@ -355,10 +353,10 @@ same variable. > 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) @@ -379,124 +377,124 @@ 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 (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. @@ -510,113 +508,113 @@ 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)" } |