[project @ 1996-12-19 09:10:02 by simonpj]

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

diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index d9ef03a..457cab2 100644 (file)
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -8,24 +8,23 @@
 
 module WorkWrap ( workersAndWrappers ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
 import CoreSyn
-import CoreUnfold      ( UnfoldingGuidance(..) )
+import CoreUnfold      ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance )
+import CmdLineOpts     ( opt_UnfoldingCreationThreshold )
+
 import CoreUtils       ( coreExprType )
 import Id              ( idWantsToBeINLINEd, getIdStrictness, mkWorkerId,
-                         getIdInfo
+                         addIdStrictness, addInlinePragma,
+                         GenId
                        )
-import IdInfo          ( noIdInfo, addInfo_UF, indicatesWorker,
-                         mkStrictnessInfo, StrictnessInfo(..)
+import IdInfo          ( noIdInfo, addUnfoldInfo,  
+                         mkStrictnessInfo, addStrictnessInfo, StrictnessInfo(..)
                        )
 import SaLib
-import UniqSupply      ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) )
+import UniqSupply      ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
 import WwLib
-import Util            ( panic{-ToDo:rm-} )
-
-replaceIdInfo = panic "WorkWrap.replaceIdInfo (ToDo)"
-iWantToBeINLINEd = panic "WorkWrap.iWantToBeINLINEd (ToDo)"
 \end{code}
 
 We take Core bindings whose binders have their strictness attached (by
@@ -185,7 +184,10 @@ tryWW      :: Id                           -- the fn binder
                                        -- if two, then a worker and a
                                        -- wrapper.
 tryWW fn_id rhs
-  | idWantsToBeINLINEd fn_id
+  | certainlySmallEnoughToInline $
+    calcUnfoldingGuidance (idWantsToBeINLINEd fn_id) 
+                         opt_UnfoldingCreationThreshold
+                         rhs
     -- No point in worker/wrappering something that is going to be
     -- INLINEd wholesale anyway.  If the strictness analyser is run
     -- twice, this test also prevents wrappers (which are INLINEd)
@@ -197,14 +199,8 @@ tryWW fn_id rhs
 
       NoStrictnessInfo    -> do_nothing
       BottomGuaranteed    -> do_nothing
-      StrictnessInfo [] _ -> do_nothing -- V weird (but possible?)
 
       StrictnessInfo args_info _ ->
-       if not (indicatesWorker args_info) then
-           do_nothing
-       else
-
-       -- OK, it looks as if a worker is worth a try
        let
             (uvars, tyvars, args, body) = collectBinders rhs
             body_ty                     = coreExprType body
@@ -212,12 +208,9 @@ tryWW fn_id rhs
        mkWwBodies body_ty tyvars args args_info `thenUs` \ result ->
        case result of
 
-         Nothing ->    -- Very peculiar. This can only happen if we hit an
-                       -- abstract type, which we shouldn't have since we've
-                       -- constructed the args_info in this module!
-
-                       -- False. We might hit the all-args-absent-and-the-
-                       -- body-is-unboxed case.  A Nothing is legit. (WDP 94/10)
+         Nothing ->    -- We've hit the all-args-absent-and-the-body-is-unboxed case,
+                       -- or there are too many args for a w/w split,
+                       -- or there's no benefit from w/w (e.g. SSS)
                        do_nothing
 
          Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
@@ -228,7 +221,7 @@ tryWW fn_id rhs
                worker_ty   = worker_ty_w_hole body_ty
 
                worker_id   = mkWorkerId worker_uniq fn_id worker_ty
-                               (noIdInfo `addInfo` worker_strictness)
+                               (noIdInfo `addStrictnessInfo` worker_strictness)
 
                wrapper_rhs = wrapper_w_hole worker_id
                worker_rhs  = worker_w_hole body
@@ -239,12 +232,9 @@ tryWW fn_id rhs
                    -- worker Id:
                    mkStrictnessInfo args_info (Just worker_id)
 
-               wrapper_id  = fn_id `replaceIdInfo`
-                             (getIdInfo fn_id          `addInfo`
-                              revised_strictness_info  `addInfo_UF`
-                              iWantToBeINLINEd UnfoldAlways)
-               -- NB! the "iWantToBeINLINEd" part adds an INLINE pragma to
-               -- the wrapper, which is of course what we want.
+               wrapper_id  = addInlinePragma (fn_id `addIdStrictness`
+                                              revised_strictness_info)
+               -- NB the "addInlinePragma" part; we want to inline wrappers everywhere
            in
            returnUs [ (worker_id,  worker_rhs),   -- worker comes first
                       (wrapper_id, wrapper_rhs) ] -- because wrapper mentions it