[project @ 2003-07-02 14:59:00 by simonpj]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CorePrep.lhs

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index 5b18681..d2515c9 100644 (file)
--- a/ghc/compiler/coreSyn/CorePrep.lhs
+++ b/ghc/compiler/coreSyn/CorePrep.lhs
@@ -15,18 +15,18 @@ 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 TcType  ( TyThing( AnId ) )

 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, isImplicitId,

                  isLocalId, hasNoBinding, idNewStrictness, 
                  isLocalId, hasNoBinding, idNewStrictness, 

-                 isDataConId_maybe, idUnfolding
+                 idUnfolding, isDataConWorkId_maybe

                )
                )

-import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
+import HscTypes   ( TypeEnv, typeEnvElts )

 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
                    RecFlag(..), isNonRec
                  )
 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
                    RecFlag(..), isNonRec
                  )

@@ -64,7 +64,7 @@ The goal of this pass is to prepare for code generation.
 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.
+5.  [Not any more; nuked Jun 2002] Do the seq/par munging.

 
 6.  Clone all local Ids.
     This means that all such Ids are unique, rather than the 
 
 6.  Clone all local Ids.
     This means that all such Ids are unique, rather than the 

@@ -97,23 +97,23 @@ any trivial or useless bindings.
 -- -----------------------------------------------------------------------------
 
 \begin{code}
 -- -----------------------------------------------------------------------------
 
 \begin{code}

-corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
-corePrepPgm dflags mod_details
+corePrepPgm :: DynFlags -> [CoreBind] -> TypeEnv -> IO [CoreBind]
+corePrepPgm dflags binds types

   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
 
   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
 

-       let implicit_binds = mkImplicitBinds (md_types mod_details)
+       let implicit_binds = mkImplicitBinds types

                -- NB: we must feed mkImplicitBinds through corePrep too
                -- so that they are suitably cloned and eta-expanded
 
            binds_out = initUs_ us (
                -- NB: we must feed mkImplicitBinds through corePrep too
                -- so that they are suitably cloned and eta-expanded
 
            binds_out = initUs_ us (

-                         corePrepTopBinds (md_binds mod_details)       `thenUs` \ floats1 ->
-                         corePrepTopBinds implicit_binds               `thenUs` \ floats2 ->
+                         corePrepTopBinds binds        `thenUs` \ floats1 ->
+                         corePrepTopBinds implicit_binds       `thenUs` \ floats2 ->

                          returnUs (deFloatTop (floats1 `appOL` floats2))
                        )
            
         endPass dflags "CorePrep" Opt_D_dump_prep binds_out
                          returnUs (deFloatTop (floats1 `appOL` floats2))
                        )
            
         endPass dflags "CorePrep" Opt_D_dump_prep binds_out

-       return (mod_details { md_binds = binds_out })
+       return binds_out

 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 corePrepExpr dflags expr
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 corePrepExpr dflags expr

@@ -155,14 +155,18 @@ partial applications. But it's easier to let them through.
 \begin{code}
 mkImplicitBinds type_env
   = [ NonRec id (get_unfolding id)
 \begin{code}
 mkImplicitBinds type_env
   = [ NonRec id (get_unfolding id)

-    | id <- implicitTyThingIds (typeEnvElts type_env) ]
+    | AnId id <- typeEnvElts type_env, isImplicitId id ]
+       -- The type environment already contains all the implicit Ids, 
+       -- so we just filter them out
+       --

        -- The etaExpand is so that the manifest arity of the
        -- binding matches its claimed arity, which is an 
        -- invariant of top level bindings going into the code gen
 
 get_unfolding id       -- See notes above
        -- The etaExpand is so that the manifest arity of the
        -- binding matches its claimed arity, which is an 
        -- invariant of top level bindings going into the code gen
 
 get_unfolding id       -- See notes above

-  | Just data_con <- isDataConId_maybe id = Var id     -- The ice is thin here, but it works
-  | otherwise                            = unfoldingTemplate (idUnfolding id)
+  | Just data_con <- isDataConWorkId_maybe id = Var id -- The ice is thin here, but it works
+                                                       -- CorePrep will eta-expand it
+  | otherwise                                = unfoldingTemplate (idUnfolding id)

 \end{code}
        
 
 \end{code}
        
 

@@ -228,6 +232,19 @@ corePrepTopBinds binds
 --     a = g y
 --     x* = f a
 -- And then x will actually end up case-bound
 --     a = g y
 --     x* = f a
 -- And then x will actually end up case-bound

+--
+-- What happens to the CafInfo on the floated bindings?  By
+-- default, all the CafInfos will be set to MayHaveCafRefs,
+-- which is safe.
+--
+-- This might be pessimistic, because eg. s1 & s2
+-- might not refer to any CAFs and the GC will end up doing
+-- more traversal than is necessary, but it's still better
+-- than not floating the bindings at all, because then
+-- the GC would have to traverse the structure in the heap
+-- instead.  Given this, we decided not to try to get
+-- the CafInfo on the floated bindings correct, because
+-- it looks difficult.

 
 --------------------------------
 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
 
 --------------------------------
 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)

@@ -341,8 +358,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 +373,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, mkCase 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') ->

@@ -439,6 +457,8 @@ corePrepExprFloat env expr@(App _ _)
          returnUs (Note note fun', hd, fun_ty, floats, ss)
 
        -- non-variable fun, better let-bind it
          returnUs (Note note fun', hd, fun_ty, floats, ss)
 
        -- non-variable fun, better let-bind it

+       -- ToDo: perhaps we can case-bind rather than let-bind this closure,
+       -- since it is sure to be evaluated.

     collect_args fun depth
        = corePrepExprFloat env fun                     `thenUs` \ (fun_floats, fun') ->
          newVar ty                                     `thenUs` \ fn_id ->
     collect_args fun depth
        = corePrepExprFloat env fun                     `thenUs` \ (fun_floats, fun') ->
          newVar ty                                     `thenUs` \ fn_id ->

@@ -447,10 +467,11 @@ corePrepExprFloat env expr@(App _ _)
         where
          ty = exprType fun
 
         where
          ty = exprType fun
 

-    ignore_note        InlineCall = True
-    ignore_note        InlineMe   = True
-    ignore_note        _other     = False
-       -- we don't ignore SCCs, since they require some code generation
+    ignore_note        (CoreNote _) = True 
+    ignore_note        InlineCall   = True
+    ignore_note        InlineMe     = True
+    ignore_note        _other       = False
+       -- We don't ignore SCCs, since they require some code generation

 
 ------------------------------------------------------------------------------
 -- Building the saturated syntax
 
 ------------------------------------------------------------------------------
 -- Building the saturated syntax

@@ -524,7 +545,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 

@@ -532,7 +553,7 @@ mkBinds binds body
   | otherwise    = deLam body          `thenUs` \ body' ->
                    returnUs (foldrOL mk_bind body' binds)
   where
   | otherwise    = deLam body          `thenUs` \ body' ->
                    returnUs (foldrOL mk_bind body' binds)
   where

-    mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
+    mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)]

     mk_bind (FloatLet bind)        body = Let bind body
 
 etaExpandRhs bndr rhs
     mk_bind (FloatLet bind)        body = Let bind body
 
 etaExpandRhs bndr rhs

@@ -579,22 +600,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
 

@@ -617,7 +645,7 @@ tryEta bndrs expr@(App _ _)
     n_remaining = length args - length bndrs
 
     ok bndr (Var arg) = bndr == arg
     n_remaining = length args - length bndrs
 
     ok bndr (Var arg) = bndr == arg

-    ok bndr other          = False
+    ok bndr other     = False

 
          -- we can't eta reduce something which must be saturated.
     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 
          -- we can't eta reduce something which must be saturated.
     ok_to_eta_reduce (Var f) = not (hasNoBinding f)

@@ -636,55 +664,6 @@ tryEta bndrs _ = Nothing
 
 
 -- -----------------------------------------------------------------------------
 
 
 -- -----------------------------------------------------------------------------

---     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@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
-                       -- DEFAULT alt is always first
-  = 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
-       -- The binder shouldn't be used in the expression!
-    new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
-              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
 -- -----------------------------------------------------------------------------
 

@@ -705,8 +684,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}