projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2002-08-20 10:32:48 by simonmar]
[ghc-hetmet.git]
/
ghc
/
compiler
/
coreSyn
/
CorePrep.lhs
diff --git
a/ghc/compiler/coreSyn/CorePrep.lhs
b/ghc/compiler/coreSyn/CorePrep.lhs
index
6e109c8
..
20e47d7
100644
(file)
--- a/
ghc/compiler/coreSyn/CorePrep.lhs
+++ b/
ghc/compiler/coreSyn/CorePrep.lhs
@@
-15,14
+15,13
@@
import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
import Type ( Type, applyTy, splitFunTy_maybe,
import CoreLint ( endPass )
import CoreSyn
import Type ( Type, applyTy, splitFunTy_maybe,
- isUnLiftedType, isUnboxedTupleType, repType, seqType )
+ isUnLiftedType, isUnboxedTupleType, seqType )
import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
-import PrimOp ( PrimOp(..) )
import Var ( Var, Id, setVarUnique )
import VarSet
import VarEnv
import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
import Var ( Var, Id, setVarUnique )
import VarSet
import VarEnv
import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
- setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
+ isFCallId, isGlobalId,
isLocalId, hasNoBinding, idNewStrictness,
isDataConId_maybe, idUnfolding
)
isLocalId, hasNoBinding, idNewStrictness,
isDataConId_maybe, idUnfolding
)
@@
-341,8
+340,8
@@
corePrepExprFloat env (Let bind body)
corePrepExprFloat env (Note n@(SCC _) expr)
= corePrepAnExpr env expr `thenUs` \ expr1 ->
corePrepExprFloat env (Note n@(SCC _) expr)
= corePrepAnExpr env expr `thenUs` \ expr1 ->
- deLam expr1 `thenUs` \ expr2 ->
- returnUs (nilOL, Note n expr2)
+ deLamFloat expr1 `thenUs` \ (floats, expr2) ->
+ returnUs (floats, Note n expr2)
corePrepExprFloat env (Note other_note expr)
= corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
corePrepExprFloat env (Note other_note expr)
= corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
@@
-356,10
+355,11
@@
corePrepExprFloat env expr@(Lam _ _)
(bndrs,body) = collectBinders expr
corePrepExprFloat env (Case scrut bndr alts)
(bndrs,body) = collectBinders expr
corePrepExprFloat env (Case scrut bndr alts)
- = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
+ = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
+ deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
mapUs (sat_alt env') alts `thenUs` \ alts' ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
mapUs (sat_alt env') alts `thenUs` \ alts' ->
- returnUs (floats, Case scrut' bndr' alts')
+ returnUs (floats1 `appOL` floats2 , Case scrut2 bndr' alts')
where
sat_alt env (con, bs, rhs)
= cloneBndrs env bs `thenUs` \ (env', bs') ->
where
sat_alt env (con, bs, rhs)
= cloneBndrs env bs `thenUs` \ (env', bs') ->
@@
-524,7
+524,7
@@
mkLocalNonRec bndr dem floats rhs
where
bndr_ty = idType bndr
where
bndr_ty = idType bndr
- bndr_rep_ty = repType bndr_ty
+
mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
mkBinds binds body
mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
mkBinds binds body
@@
-579,22
+579,29
@@
etaExpandRhs bndr rhs
-- We arrange that they only show up as the RHS of a let(rec)
-- ---------------------------------------------------------------------------
-- We arrange that they only show up as the RHS of a let(rec)
-- ---------------------------------------------------------------------------
-deLam :: CoreExpr -> UniqSM CoreExpr
+deLam :: CoreExpr -> UniqSM CoreExpr
+deLam expr =
+ deLamFloat expr `thenUs` \ (floats, expr) ->
+ mkBinds floats expr
+
+
+deLamFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
-- Remove top level lambdas by let-bindinig
-- Remove top level lambdas by let-bindinig
-deLam (Note n expr)
+deLamFloat (Note n expr)
= -- You can get things like
-- case e of { p -> coerce t (\s -> ...) }
= -- You can get things like
-- case e of { p -> coerce t (\s -> ...) }
- deLam expr `thenUs` \ expr' ->
- returnUs (Note n expr')
+ deLamFloat expr `thenUs` \ (floats, expr') ->
+ returnUs (floats, Note n expr')
-deLam expr
- | null bndrs = returnUs expr
+deLamFloat expr
+ | null bndrs = returnUs (nilOL, expr)
| otherwise
= case tryEta bndrs body of
| otherwise
= case tryEta bndrs body of
- Just no_lam_result -> returnUs no_lam_result
+ Just no_lam_result -> returnUs (nilOL, no_lam_result)
Nothing -> newVar (exprType expr) `thenUs` \ fn ->
Nothing -> newVar (exprType expr) `thenUs` \ fn ->
- returnUs (Let (NonRec fn expr) (Var fn))
+ returnUs (unitOL (FloatLet (NonRec fn expr)),
+ Var fn)
where
(bndrs,body) = collectBinders expr
where
(bndrs,body) = collectBinders expr
@@
-656,8
+663,10
@@
bdrDem :: Id -> RhsDemand
bdrDem id = mkDem (idNewDemandInfo id)
False {- For now -}
bdrDem id = mkDem (idNewDemandInfo id)
False {- For now -}
-safeDem, onceDem :: RhsDemand
-safeDem = RhsDemand False False -- always safe to use this
+-- safeDem :: RhsDemand
+-- safeDem = RhsDemand False False -- always safe to use this
+
+onceDem :: RhsDemand
onceDem = RhsDemand False True -- used at most once
\end{code}
onceDem = RhsDemand False True -- used at most once
\end{code}