Fix a buglet in CorePrep: an expression such as
case __coerce (\x -> e) :: T of { ... }
would be left as is, but the lambda expression should really be
abstracted as a let (causes a panic later in srtExpr; shown up by
the dynamic001 test). There was a missing call to deLam in the case
for Case expressions in corePrepExprFloat.
In addition, I made a new version of deLam, deLamFloat, which can
float any bindings generated. This helps to generate slightly cleaner
code in the above case (the binding is floated out of the scrutinee).
Also: GC unused imports while I'm here.
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,
isLocalId, hasNoBinding, idNewStrictness,
isDataConId_maybe, idUnfolding
)
isLocalId, hasNoBinding, idNewStrictness,
isDataConId_maybe, idUnfolding
)
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') ->
(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') ->
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
-- 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
+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
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}