remove empty dir

[ghc-hetmet.git] / ghc / compiler / stranal / WorkWrap.lhs

diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index 6ceda4f..64eba89 100644 (file)
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -11,11 +11,12 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where
 import CoreSyn
 import CoreUnfold      ( certainlyWillInline )
 import CoreLint                ( showPass, endPass )
-import CoreUtils       ( exprType, exprIsValue )
-import Id              ( Id, idType, isOneShotLambda,
+import CoreUtils       ( exprType, exprIsHNF )
+import Id              ( Id, idType, isOneShotLambda, 
                          setIdNewStrictness, mkWorkerId,
                          setIdWorkerInfo, setInlinePragma,
                          idInfo )
+import MkId            ( lazyIdKey, lazyIdUnfolding )
 import Type            ( Type )
 import IdInfo          ( WorkerInfo(..), arityInfo,
                          newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo
@@ -24,12 +25,13 @@ import NewDemand        ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
                          Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
                        )
 import UniqSupply      ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
+import Unique          ( hasKey )
 import BasicTypes      ( RecFlag(..), isNonRec, Activation(..) )
 import VarEnv          ( isEmptyVarEnv )
 import Maybes          ( orElse )
-import CmdLineOpts
+import DynFlags
 import WwLib
-import Util            ( lengthIs )
+import Util            ( lengthIs, notNull )
 import Outputable
 \end{code}
 
@@ -127,9 +129,16 @@ matching by looking for strict arguments of the correct type.
 \begin{code}
 wwExpr :: CoreExpr -> UniqSM CoreExpr
 
-wwExpr e@(Type _)   = returnUs e
-wwExpr e@(Var _)    = returnUs e
-wwExpr e@(Lit _)    = returnUs e
+wwExpr e@(Type _)            = returnUs e
+wwExpr e@(Lit _)             = returnUs e
+wwExpr e@(Note InlineMe expr) = returnUs e
+       -- Don't w/w inside InlineMe's
+
+wwExpr e@(Var v)
+  | v `hasKey` lazyIdKey = returnUs lazyIdUnfolding
+  | otherwise            = returnUs e
+       -- Inline 'lazy' after strictness analysis
+       -- (but not inside InlineMe's)
 
 wwExpr (Lam binder expr)
   = wwExpr expr                        `thenUs` \ new_expr ->
@@ -149,10 +158,10 @@ wwExpr (Let bind expr)
     wwExpr expr                        `thenUs` \ new_expr ->
     returnUs (mkLets intermediate_bind new_expr)
 
-wwExpr (Case expr binder alts)
+wwExpr (Case expr binder ty alts)
   = wwExpr expr                                `thenUs` \ new_expr ->
     mapUs ww_alt alts                  `thenUs` \ new_alts ->
-    returnUs (Case new_expr binder new_alts)
+    returnUs (Case new_expr binder ty new_alts)
   where
     ww_alt (con, binders, rhs)
       =        wwExpr rhs                      `thenUs` \ new_rhs ->
@@ -202,41 +211,40 @@ tryWW is_rec fn_id rhs
        --      fw = \ab -> (__inline (\x -> E)) (a,b)
        -- and the original __inline now vanishes, so E is no longer
        -- inside its __inline wrapper.  Death!  Disaster!
-  = returnUs [ (fn_id', rhs) ]
+  = returnUs [ (new_fn_id, rhs) ]
 
-  | is_thunk && worthSplittingThunk fn_dmd res_info
-  = ASSERT( isNonRec is_rec )  -- The thunk must be non-recursive
-    splitThunk fn_id' rhs
+  | is_thunk && worthSplittingThunk maybe_fn_dmd res_info
+  = ASSERT2( isNonRec is_rec, ppr new_fn_id )  -- The thunk must be non-recursive
+    splitThunk new_fn_id rhs
 
   | is_fun && worthSplittingFun wrap_dmds res_info
-  = splitFun fn_id' fn_info wrap_dmds res_info inline_prag rhs
+  = splitFun new_fn_id fn_info wrap_dmds res_info inline_prag rhs
 
   | otherwise
-  = returnUs [ (fn_id', rhs) ]
+  = returnUs [ (new_fn_id, rhs) ]
 
   where
-    fn_info    = idInfo fn_id
-    fn_dmd     = newDemandInfo fn_info
-    unfolding  = unfoldingInfo fn_info
-    inline_prag = inlinePragInfo fn_info
-    maybe_sig   = newStrictnessInfo fn_info
+    fn_info     = idInfo fn_id
+    maybe_fn_dmd = newDemandInfo fn_info
+    unfolding   = unfoldingInfo fn_info
+    inline_prag  = inlinePragInfo fn_info
 
        -- In practice it always will have a strictness 
        -- signature, even if it's a uninformative one
     strict_sig  = newStrictnessInfo fn_info `orElse` topSig
     StrictSig (DmdType env wrap_dmds res_info) = strict_sig
 
-       -- fn_id' has the DmdEnv zapped.  
+       -- new_fn_id has the DmdEnv zapped.  
        --      (a) it is never used again
        --      (b) it wastes space
        --      (c) it becomes incorrect as things are cloned, because
        --          we don't push the substitution into it
-    fn_id' | isEmptyVarEnv env = fn_id
-          | otherwise         = fn_id `setIdNewStrictness` 
-                                  StrictSig (mkTopDmdType wrap_dmds res_info)
+    new_fn_id | isEmptyVarEnv env = fn_id
+             | otherwise         = fn_id `setIdNewStrictness` 
+                                    StrictSig (mkTopDmdType wrap_dmds res_info)
 
-    is_fun    = not (null wrap_dmds)
-    is_thunk  = not is_fun && not (exprIsValue rhs)
+    is_fun    = notNull wrap_dmds
+    is_thunk  = not is_fun && not (exprIsHNF rhs)
 
 ---------------------
 splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
@@ -360,15 +368,15 @@ worthSplittingFun ds res
     worth_it (Eval (Prod ds)) = True   -- Product arg to evaluate
     worth_it other           = False
 
-worthSplittingThunk :: Demand          -- Demand on the thunk
+worthSplittingThunk :: Maybe Demand    -- Demand on the thunk
                    -> DmdResult        -- CPR info for the thunk
                    -> Bool
-worthSplittingThunk dmd res
-  = worth_it dmd || returnsCPR res
+worthSplittingThunk maybe_dmd res
+  = worth_it maybe_dmd || returnsCPR res
   where
        -- Split if the thing is unpacked
-    worth_it (Eval (Prod ds)) = not (all isAbsent ds)
-    worth_it other           = False
+    worth_it (Just (Eval (Prod ds))) = not (all isAbsent ds)
+    worth_it other                  = False
 \end{code}