isUnLiftedType, isUnboxedTupleType, repType,
uaUTy, usOnce, usMany, seqType )
import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) )
+import PrimOp ( PrimOp(..) )
import Var ( Id, TyVar, setTyVarUnique )
import VarSet
import IdInfo ( IdFlavour(..) )
-import Id ( mkSysLocal, idType, idStrictness, idFlavour, idDemandInfo, idArity )
+import Id ( mkSysLocal, idType, idStrictness, idFlavour, idDemandInfo, idArity,
+ isDeadBinder, setIdType, isPrimOpId_maybe
+ )
import UniqSupply
import Maybes
4. Ensure that lambdas only occur as the RHS of a binding
(The code generator can't deal with anything else.)
+5. Do the seq/par munging. See notes with mkCase below.
+
This is all done modulo type applications and abstractions, so that
when type erasure is done for conversion to STG, we don't end up with
any trivial or useless bindings.
coreSatExprFloat (Case scrut bndr alts)
= coreSatExprFloat scrut `thenUs` \ (floats, scrut) ->
mapUs sat_alt alts `thenUs` \ alts ->
- returnUs (floats, Case scrut bndr alts)
+ returnUs (floats, mkCase scrut bndr alts)
where
sat_alt (con, bs, rhs)
= coreSatAnExpr rhs `thenUs` \ rhs ->
| otherwise = deLam body `thenUs` \ body' ->
returnUs (foldOL mk_bind body' binds)
where
- mk_bind (FloatCase bndr rhs) body = Case rhs bndr [(DEFAULT, [], body)]
+ mk_bind (FloatCase bndr rhs) body = mkCase rhs bndr [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
-- ---------------------------------------------------------------------------
fvs = exprFreeVars r
tryEta bndrs _ = Nothing
+\end{code}
+
+
+-- -----------------------------------------------------------------------------
+-- Do the seq and par transformation
+-- -----------------------------------------------------------------------------
+
+Here we do two pre-codegen transformations:
+
+1. case seq# a of {
+ 0 -> seqError ...
+ DEFAULT -> rhs }
+ ==>
+ case a of { DEFAULT -> rhs }
+
+
+2. case par# a of {
+ 0 -> parError ...
+ DEFAULT -> rhs }
+ ==>
+ case par# a of {
+ DEFAULT -> rhs }
+
+NB: seq# :: a -> Int# -- Evaluate value and return anything
+ par# :: a -> Int# -- Spark value and return anything
+
+These transformations can't be done earlier, or else we might
+think that the expression was strict in the variables in which
+rhs is strict --- but that would defeat the purpose of seq and par.
+
+
+\begin{code}
+mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts
+ = case isPrimOpId_maybe fn of
+ Just ParOp -> Case scrut bndr [deflt_alt]
+ Just SeqOp ->
+ Case arg new_bndr [deflt_alt]
+ other -> Case scrut bndr alts
+ where
+ (deflt_alt : _) = [alt | alt@(DEFAULT,_,_) <- alts]
+
+ new_bndr = ASSERT( isDeadBinder bndr ) -- The binder shouldn't be used in the expression!
+ setIdType bndr (exprType arg)
+ -- NB: SeqOp :: forall a. a -> Int#
+ -- So bndr has type Int#
+ -- But now we are going to scrutinise the SeqOp's argument directly,
+ -- so we must change the type of the case binder to match that
+ -- of the argument expression e.
+
+mkCase scrut bndr alts = Case scrut bndr alts
+\end{code}
+
-- -----------------------------------------------------------------------------
-- Demands
-- -----------------------------------------------------------------------------
+\begin{code}
data RhsDemand
= RhsDemand { isStrictDem :: Bool, -- True => used at least once
isOnceDem :: Bool -- True => used at most once
SimplifierSwitch(..)
)
import SimplMonad
-import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion, findAlt,
- simplBinder, simplBinders, simplIds, findDefault,
+import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion,
+ simplBinder, simplBinders, simplIds,
SimplCont(..), DupFlag(..), mkStop, mkRhsStop,
contResultType, discardInline, countArgs, contIsDupable,
getContArgs, interestingCallContext, interestingArg, isStrictType
callSiteInline
)
import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial,
- exprIsConApp_maybe, mkPiType,
+ exprIsConApp_maybe, mkPiType, findAlt, findDefault,
exprType, coreAltsType, exprIsValue,
exprOkForSpeculation, exprArity, exprIsCheap,
mkCoerce, mkSCC, mkInlineMe, mkAltExpr
live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
in
returnLne (
- mkStgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2,
+ StgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2,
(scrut_fvs `unionFVInfo` alts_fvs) `minusFVBinders` [bndr],
(alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
-- You might think we should have scrut_escs, not (getFVSet scrut_fvs),
\end{code}
\begin{code}
-mkStgCase scrut@(StgPrimApp ParOp _ _) lvs1 lvs2 bndr srt
- (StgPrimAlts tycon _ deflt@(StgBindDefault _))
- = StgCase scrut lvs1 lvs2 bndr srt (StgPrimAlts tycon [] deflt)
-
-mkStgCase (StgPrimApp SeqOp [scrut] _) lvs1 lvs2 bndr srt
- (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
- = StgCase scrut_expr lvs1 lvs2 new_bndr srt new_alts
- where
- new_alts
- | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" )
- mkStgPrimAlts scrut_ty [] deflt
- | otherwise = mkStgAlgAlts scrut_ty [] deflt
-
- scrut_ty = stgArgType scrut
- new_bndr = setIdType bndr scrut_ty
- -- NB: SeqOp :: forall a. a -> Int#
- -- So bndr has type Int#
- -- But now we are going to scrutinise the SeqOp's argument directly,
- -- so we must change the type of the case binder to match that
- -- of the argument expression e.
-
- scrut_expr = case scrut of
- StgVarArg v -> StgApp v []
- -- Others should not happen because
- -- seq of a value should have disappeared
- StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
-
-mkStgCase scrut lvs1 lvs2 bndr srt alts
- = StgCase scrut lvs1 lvs2 bndr srt alts
-
-
mkStgAlgAlts ty alts deflt
= case alts of
-- Get the tycon from the data con
projects / ghc-hetmet.git / commitdiff