[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 (file)
--- 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(..) )
                  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 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
 
 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.)
 
 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.
 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 ->
 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 ->
   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
   | 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
 
 -- ---------------------------------------------------------------------------
     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
     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
 -- -----------------------------------------------------------------------------
 
 
 -- -----------------------------------------------------------------------------
 -- Demands
 -- -----------------------------------------------------------------------------
 

+\begin{code}

 data RhsDemand
      = RhsDemand { isStrictDem :: Bool,  -- True => used at least once
                    isOnceDem   :: Bool   -- True => used at most once
 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 (file)
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -456,6 +456,7 @@ coreExprCc other               = noCostCentre
 \end{code}
 
 
 \end{code}
 
 

+

 %************************************************************************
 %*                                                                     *
 \subsection{Predicates}
 %************************************************************************
 %*                                                                     *
 \subsection{Predicates}

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index c766c8f..131b56c 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -14,8 +14,8 @@ import CmdLineOpts    ( switchIsOn, opt_SimplDoEtaReduction,
                          SimplifierSwitch(..)
                        )
 import SimplMonad
                          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
                          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, 
                          callSiteInline
                        )
 import CoreUtils       ( cheapEqExpr, exprIsDupable, exprIsTrivial, 

-                         exprIsConApp_maybe, mkPiType,
+                         exprIsConApp_maybe, mkPiType, findAlt, findDefault,

                          exprType, coreAltsType, exprIsValue, 
                          exprOkForSpeculation, exprArity, exprIsCheap,
                          mkCoerce, mkSCC, mkInlineMe, mkAltExpr
                          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 (file)
--- 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 (
        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),
       (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}
 \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
 mkStgAlgAlts ty alts deflt
  =  case alts of
                -- Get the tycon from the data con