From: simonpj Date: Mon, 26 Feb 2001 15:42:24 +0000 (+0000) Subject: [project @ 2001-02-26 15:42:24 by simonpj] X-Git-Tag: Approximately_9120_patches~2548 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=44637383d831bd3ca8f3aa3cf80e6a0c90986b41 [project @ 2001-02-26 15:42:24 by simonpj] Move seq/par munging from CoreToStg to CoreSat --- diff --git a/ghc/compiler/coreSyn/CoreSat.lhs b/ghc/compiler/coreSyn/CoreSat.lhs index 9fdcc09..3e53e9e 100644 --- a/ghc/compiler/coreSyn/CoreSat.lhs +++ b/ghc/compiler/coreSyn/CoreSat.lhs @@ -18,10 +18,13 @@ import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy, 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 @@ -70,6 +73,8 @@ primary goals here are: 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. @@ -255,7 +260,7 @@ coreSatExprFloat expr@(Lam _ _) 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 -> @@ -422,7 +427,7 @@ mkBinds binds body | 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 -- --------------------------------------------------------------------------- @@ -486,11 +491,64 @@ tryEta bndrs (Let bind@(NonRec b r) 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 diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 7d28354..b78bbcf 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -456,6 +456,7 @@ coreExprCc other = noCostCentre \end{code} + %************************************************************************ %* * \subsection{Predicates} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index c766c8f..131b56c 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -14,8 +14,8 @@ import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction, 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 @@ -44,7 +44,7 @@ import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline ) import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, - exprIsConApp_maybe, mkPiType, + exprIsConApp_maybe, mkPiType, findAlt, findDefault, exprType, coreAltsType, exprIsValue, exprOkForSpeculation, exprArity, exprIsCheap, mkCoerce, mkSCC, mkInlineMe, mkAltExpr diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 9bad7a9..e4752c5 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -329,7 +329,7 @@ coreToStgExpr (Case scrut bndr alts) 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), @@ -428,37 +428,6 @@ isForeignObjPrimTy ty \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