remove empty dir

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

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index f918d72..e5165f0 100644 (file)
--- a/ghc/compiler/coreSyn/CorePrep.lhs
+++ b/ghc/compiler/coreSyn/CorePrep.lhs
@@ -10,24 +10,24 @@ module CorePrep (
 
 #include "HsVersions.h"
 
-import CoreUtils( exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
+import CoreUtils( exprType, exprIsHNF, etaExpand, exprArity, exprOkForSpeculation )
 import CoreFVs ( exprFreeVars )
 import CoreLint        ( endPass )
 import CoreSyn
 import Type    ( Type, applyTy, splitFunTy_maybe, 
                  isUnLiftedType, isUnboxedTupleType, seqType )
+import TyCon   ( TyCon, tyConDataCons )
 import NewDemand  ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
 import Var     ( Var, Id, setVarUnique )
 import VarSet
 import VarEnv
 import Id      ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, setIdType,
-                 isFCallId, isGlobalId, isImplicitId,
+                 isFCallId, isGlobalId, 
                  isLocalId, hasNoBinding, idNewStrictness, 
-                 idUnfolding, isDataConWorkId_maybe, isPrimOpId_maybe
+                 isPrimOpId_maybe
                )
-import DataCon   ( isVanillaDataCon )
+import DataCon   ( isVanillaDataCon, dataConWorkId )
 import PrimOp    ( PrimOp( DataToTagOp ) )
-import HscTypes   ( TypeEnv, typeEnvElts, TyThing( AnId ) )
 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
                    RecFlag(..), isNonRec
                  )
@@ -98,12 +98,12 @@ any trivial or useless bindings.
 -- -----------------------------------------------------------------------------
 
 \begin{code}
-corePrepPgm :: DynFlags -> [CoreBind] -> TypeEnv -> IO [CoreBind]
-corePrepPgm dflags binds types
+corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
+corePrepPgm dflags binds data_tycons
   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
 
-       let implicit_binds = mkImplicitBinds types
+       let implicit_binds = mkDataConWorkers data_tycons
                -- NB: we must feed mkImplicitBinds through corePrep too
                -- so that they are suitably cloned and eta-expanded
 
@@ -130,16 +130,8 @@ corePrepExpr dflags expr
 -- Implicit bindings
 -- -----------------------------------------------------------------------------
 
-Create any necessary "implicit" bindings (data constructors etc).
-Namely:
-       * Constructor workers
-       * Constructor wrappers
-       * Data type record selectors
-       * Class op selectors
-
-In the latter three cases, the Id contains the unfolding to use for
-the binding.  In the case of data con workers we create the rather 
-strange (non-recursive!) binding
+Create any necessary "implicit" bindings for data con workers.  We
+create the rather strange (non-recursive!) binding
 
        $wC = \x y -> $wC x y
 
@@ -154,20 +146,11 @@ always fully applied, and the bindings are just there to support
 partial applications. But it's easier to let them through.
 
 \begin{code}
-mkImplicitBinds type_env
-  = [ NonRec id (get_unfolding id)
-    | 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
-  | 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)
+mkDataConWorkers data_tycons
+  = [ NonRec id (Var id)       -- The ice is thin here, but it works
+    | tycon <- data_tycons,    -- CorePrep will eta-expand it
+      data_con <- tyConDataCons tycon,
+      let id = dataConWorkId data_con ]
 \end{code}
        
 
@@ -561,7 +544,7 @@ maybeSaturate fn expr n_args floats ty
        -- Ensure that the argument of DataToTagOp is evaluated
     eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
     eval_data2tag_arg app@(fun `App` arg)
-       | exprIsValue arg               -- Includes nullary constructors
+       | exprIsHNF arg         -- Includes nullary constructors
        = returnUs (emptyFloats, app)   -- The arg is evaluated
        | otherwise                     -- Arg not evaluated, so evaluate it
        = newVar (exprType arg)         `thenUs` \ arg_id ->
@@ -590,7 +573,7 @@ floatRhs :: TopLevelFlag -> RecFlag
                    CoreExpr)   -- Final Rhs
 
 floatRhs top_lvl is_rec bndr (floats, rhs)
-  | isTopLevel top_lvl || exprIsValue rhs,     -- Float to expose value or 
+  | isTopLevel top_lvl || exprIsHNF rhs,       -- Float to expose value or 
     allLazy top_lvl is_rec floats              -- at top level
   =    -- Why the test for allLazy? 
        --      v = f (x `divInt#` y)
@@ -623,7 +606,7 @@ mkLocalNonRec bndr dem floats rhs
  = let         -- Don't make a case for a value binding,
                -- even if it's strict.  Otherwise we get
                --      case (\x -> e) of ...!
-       float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
+       float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
              | otherwise       = FloatCase bndr rhs (exprOkForSpeculation rhs)
     in
     returnUs (addFloat floats float, evald_bndr)
@@ -631,7 +614,7 @@ mkLocalNonRec bndr dem floats rhs
   | otherwise
   = floatRhs NotTopLevel NonRecursive bndr (floats, rhs)       `thenUs` \ (floats', rhs') ->
     returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
-             if exprIsValue rhs' then evald_bndr else bndr)
+             if exprIsHNF rhs' then evald_bndr else bndr)
 
   where
     evald_bndr = bndr `setIdUnfolding` evaldUnfolding