Fix Trac #3259: expose 'lazy' only after generating interface files

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

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 908c90c..89ec98f 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -11,6 +11,7 @@ module CorePrep (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import PrelNames       ( lazyIdKey, hasKey )

 import CoreUtils
 import CoreArity
 import CoreFVs
 import CoreUtils
 import CoreArity
 import CoreFVs

@@ -89,6 +90,8 @@ The goal of this pass is to prepare for code generation.
     We want curried definitions for all of these in case they
     aren't inlined by some caller.
        
     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.
 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.

@@ -341,9 +344,14 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 
 cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
 cpeRhsE _env expr@(Lit _)  = return (emptyFloats, expr)
 
 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 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
 cpeRhsE env (Let bind expr)
   = do { (env', new_binds) <- cpeBind NotTopLevel env bind
        ; (floats, body) <- cpeRhsE env' expr

@@ -407,7 +415,7 @@ rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
 
 --------
 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
 
 --------
 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)

--- Remove top level lambdas by let-bindinig
+-- Remove top level lambdas by let-binding

 
 rhsToBody (Note n expr)
         -- You can get things like
 
 rhsToBody (Note n expr)
         -- You can get things like

@@ -475,7 +483,7 @@ cpeApp env expr
 
     collect_args (App fun arg) depth
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
 
     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, [])
               (ss1, ss_rest)   = case ss of
                                    (ss1:ss_rest) -> (ss1,     ss_rest)
                                    []            -> (lazyDmd, [])

@@ -511,10 +519,10 @@ cpeApp env expr
       = collect_args fun depth  -- They aren't used by the code generator
 
        -- N-variable fun, better let-bind it
       = collect_args fun depth  -- They aren't used by the code generator
 
        -- N-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
       = do { (fun_floats, fun') <- cpeArg env True fun ty
     collect_args fun depth
       = do { (fun_floats, fun') <- cpeArg env True fun ty

+                         -- The True says that it's sure to be evaluated,
+                         -- so we'll end up case-binding it

            ; return (fun', (fun', depth), ty, fun_floats, []) }
         where
          ty = exprType fun
            ; return (fun', (fun', depth), ty, fun_floats, []) }
         where
          ty = exprType fun