X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCorePrep.lhs;h=738bf82bc66e205693d77fb4975fad80deec517a;hb=064812423073e89805c16311728cfded5d50e306;hp=3a6d037979b3fea5f11e38dab2fc42d1548f691f;hpb=fce8977b62fa277fa612d7caee2b31d5a8224f0d;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 3a6d037..738bf82 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -11,15 +11,16 @@ module CorePrep (
 
 #include "HsVersions.h"
 
+import PrelNames	( lazyIdKey, hasKey )
 import CoreUtils
 import CoreArity
 import CoreFVs
-import CoreLint
+import CoreMonad	( endPass )
 import CoreSyn
 import Type
 import Coercion
 import TyCon
-import NewDemand
+import Demand
 import Var
 import VarSet
 import VarEnv
@@ -85,10 +86,11 @@ The goal of this pass is to prepare for code generation.
 8.  Inject bindings for the "implicit" Ids:
 	* Constructor wrappers
 	* Constructor workers
-	* Record selectors
     We want curried definitions for all of these in case they
     aren't inlined by some caller.
 	
+9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.lhs
+
 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.
@@ -145,7 +147,7 @@ corePrepPgm dflags binds data_tycons = do
                       floats2 <- corePrepTopBinds implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 
-    endPass dflags "CorePrep" Opt_D_dump_prep binds_out
+    endPass dflags "CorePrep" Opt_D_dump_prep binds_out []
     return binds_out
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
@@ -242,7 +244,7 @@ cpeBind :: TopLevelFlag
 	-> UniqSM (CorePrepEnv, Floats)
 cpeBind top_lvl env (NonRec bndr rhs)
   = do { (_, bndr1) <- cloneBndr env bndr
-       ; let is_strict   = isStrictDmd (idNewDemandInfo bndr)
+       ; let is_strict   = isStrictDmd (idDemandInfo bndr)
              is_unlifted = isUnLiftedType (idType bndr)
        ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive 
        	 	  	       	  	  (is_strict || is_unlifted) 
@@ -341,9 +343,14 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 
 cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
 cpeRhsE _env expr@(Lit _)  = return (emptyFloats, expr)
-cpeRhsE env expr@(App {})  = cpeApp env expr
 cpeRhsE env expr@(Var {})  = cpeApp env expr
 
+cpeRhsE env (Var f `App` _ `App` arg)
+  | f `hasKey` lazyIdKey  	  -- Replace (lazy a) by a
+  = cpeRhsE env arg		  -- See Note [lazyId magic] in MkId
+
+cpeRhsE env expr@(App {}) = cpeApp env expr
+
 cpeRhsE env (Let bind expr)
   = do { (env', new_binds) <- cpeBind NotTopLevel env bind
        ; (floats, body) <- cpeRhsE env' expr
@@ -475,7 +482,7 @@ cpeApp env expr
 
     collect_args (App fun arg) depth
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
-           ; let
+      	   ; let
               (ss1, ss_rest)   = case ss of
                                    (ss1:ss_rest) -> (ss1,     ss_rest)
                                    []            -> (lazyDmd, [])
@@ -490,7 +497,7 @@ cpeApp env expr
            ; let v2 = lookupCorePrepEnv env v1
            ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
 	where
-	  stricts = case idNewStrictness v of
+	  stricts = case idStrictness v of
 			StrictSig (DmdType _ demands _)
 			    | listLengthCmp demands depth /= GT -> demands
 			            -- length demands <= depth
@@ -633,7 +640,6 @@ ignoreNote :: Note -> Bool
 -- want to get this:
 --     unzip = /\ab \xs. (__inline_me__ ...) a b xs
 ignoreNote (CoreNote _) = True 
-ignoreNote InlineMe     = True
 ignoreNote _other       = False