Tidy up computation of result discounts in CoreUnfold

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

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 3a6d037..738bf82 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -11,15 +11,16 @@ module CorePrep (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import PrelNames       ( lazyIdKey, hasKey )

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

-import CoreLint
+import CoreMonad       ( endPass )

 import CoreSyn
 import Type
 import Coercion
 import TyCon
 import CoreSyn
 import Type
 import Coercion
 import TyCon

-import NewDemand
+import Demand

 import Var
 import VarSet
 import VarEnv
 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
 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.
        
     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.

@@ -145,7 +147,7 @@ corePrepPgm dflags binds data_tycons = do
                       floats2 <- corePrepTopBinds implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 
                       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
     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
        -> 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) 
              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@(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

@@ -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)
 
     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, [])

@@ -490,7 +497,7 @@ cpeApp env expr
            ; let v2 = lookupCorePrepEnv env v1
            ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
        where
            ; 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
                        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 
 -- want to get this:
 --     unzip = /\ab \xs. (__inline_me__ ...) a b xs
 ignoreNote (CoreNote _) = True 

-ignoreNote InlineMe     = True

 ignoreNote _other       = False
 
 
 ignoreNote _other       = False