Completely new treatment of INLINE pragmas (big patch)

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

diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index 3af7e2d..6ddbbd8 100644 (file)
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -16,18 +16,16 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where
 #include "HsVersions.h"
 
 import CoreSyn
-import CoreUnfold      ( certainlyWillInline )
+import CoreUnfold      ( certainlyWillInline, mkWwInlineRule )
 import CoreLint                ( showPass, endPass )
 import CoreUtils       ( exprType, exprIsHNF, exprArity )
 import Id              ( Id, idType, isOneShotLambda, 
                          setIdNewStrictness, mkWorkerId,
-                         setIdWorkerInfo, setInlinePragma,
-                         setIdArity, idInfo )
+                         setInlinePragma, setIdUnfolding, setIdArity, idInfo )
 import MkId            ( lazyIdKey, lazyIdUnfolding )
 import Type            ( Type )
-import IdInfo          ( WorkerInfo(..), arityInfo,
-                         newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo
-                       )
+import IdInfo          ( arityInfo, newDemandInfo, newStrictnessInfo, 
+                         unfoldingInfo, inlinePragInfo )
 import NewDemand        ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), 
                          Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
                        )
@@ -36,10 +34,10 @@ import Unique               ( hasKey )
 import BasicTypes      ( RecFlag(..), isNonRec, isNeverActive )
 import VarEnv          ( isEmptyVarEnv )
 import Maybes          ( orElse )
-import DynFlags
 import WwLib
 import Util            ( lengthIs, notNull )
 import Outputable
+import MonadUtils
 \end{code}
 
 We take Core bindings whose binders have:
@@ -69,30 +67,9 @@ info for exported values).
 \end{enumerate}
 
 \begin{code}
+wwTopBinds :: UniqSupply -> [CoreBind] -> [CoreBind]
 
-wwTopBinds :: DynFlags 
-          -> UniqSupply
-          -> [CoreBind]
-          -> IO [CoreBind]
-
-wwTopBinds dflags us binds
-  = do {
-       showPass dflags "Worker Wrapper binds";
-
-       -- Create worker/wrappers, and mark binders with their
-       -- "strictness info" [which encodes their worker/wrapper-ness]
-       let { binds' = workersAndWrappers us binds };
-
-       endPass dflags "Worker Wrapper binds" 
-               Opt_D_dump_worker_wrapper binds'
-    }
-\end{code}
-
-
-\begin{code}
-workersAndWrappers :: UniqSupply -> [CoreBind] -> [CoreBind]
-
-workersAndWrappers us top_binds
+wwTopBinds us top_binds
   = initUs_ us $ do
     top_binds' <- mapM wwBind top_binds
     return (concat top_binds')
@@ -135,16 +112,12 @@ matching by looking for strict arguments of the correct type.
 \begin{code}
 wwExpr :: CoreExpr -> UniqSM CoreExpr
 
-wwExpr e@(Type _)             = return e
-wwExpr e@(Lit _)              = return e
-wwExpr e@(Note InlineMe expr) = return e
-       -- Don't w/w inside InlineMe's
-
+wwExpr e@(Type _) = return e
+wwExpr e@(Lit _)  = return e
 wwExpr e@(Var v)
   | v `hasKey` lazyIdKey = return lazyIdUnfolding
   | otherwise            = return e
        -- HACK alert: Inline 'lazy' after strictness analysis
-       -- (but not inside InlineMe's)
 
 wwExpr (Lam binder expr)
   = Lam binder <$> wwExpr expr
@@ -193,7 +166,10 @@ The only reason this is monadised is for the unique supply.
 Note [Don't w/w inline things]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It's very important to refrain from w/w-ing an INLINE function
-If we do so by mistake we transform
+because the wrapepr will then overwrite the InlineRule unfolding.
+
+It was wrong with the old InlineMe Note too: if we do so by mistake 
+we transform
        f = __inline (\x -> E)
 into
        f = __inline (\x -> case x of (a,b) -> fw E)
@@ -266,11 +242,12 @@ tryWW is_rec fn_id rhs
 
 ---------------------
 splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
-  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do
+  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) 
+    (do {
        -- The arity should match the signature
-    (work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots
-    work_uniq <- getUniqueM
-    let
+      (work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots
+    ; work_uniq <- getUniqueM
+    ; let
        work_rhs = work_fn rhs
        work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs) 
                        `setInlinePragma` inline_prag
@@ -288,9 +265,9 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
                                 -- arity is consistent with the demand type goes through
 
        wrap_rhs = wrap_fn work_id
-       wrap_id  = fn_id `setIdWorkerInfo` HasWorker work_id arity
+       wrap_id  = fn_id `setIdUnfolding` mkWwInlineRule wrap_rhs arity work_id
 
-    return ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
+    ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) })
        -- Worker first, because wrapper mentions it
        -- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it
   where
@@ -309,7 +286,7 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
 -- Otherwise we spuriously float stuff out of case-expression join points,
 -- which is very annoying.
 get_one_shots (Lam b e)
-  | isId b    = isOneShotLambda b : get_one_shots e
+  | isIdVar b = isOneShotLambda b : get_one_shots e
   | otherwise = get_one_shots e
 get_one_shots (Note _ e) = get_one_shots e
 get_one_shots other     = noOneShotInfo