X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCorePrep.lhs;h=e5165f0ebe98ed34e3aa052a04f5b7d167d58c65;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=d7d2a999fcb703a9a7d6283ee430360256dc9dd0;hpb=c685ccf47413f070a85c4b739d9d7cc73e6f38e6;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index d7d2a99..e5165f0 100644
--- 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
 		  )
@@ -35,7 +35,7 @@ import UniqSupply
 import Maybes
 import OrdList
 import ErrUtils
-import CmdLineOpts
+import DynFlags
 import Util       ( listLengthCmp )
 import Outputable
 \end{code}
@@ -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