[project @ 1998-02-25 19:17:19 by sof]

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

diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index 1b133b1..fbac09b 100644 (file)
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -4,27 +4,27 @@
 \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
 
 \begin{code}
-#include "HsVersions.h"
-
-module WorkWrap ( workersAndWrappers ) where
+module WorkWrap ( workersAndWrappers, getWorkerIdAndCons ) where
 
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
 
 import CoreSyn
 import CoreUnfold      ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance )
 import CmdLineOpts     ( opt_UnfoldingCreationThreshold )
 
 import CoreUtils       ( coreExprType )
-import Id              ( idWantsToBeINLINEd, getIdStrictness, mkWorkerId,
+import Id              ( getInlinePragma, getIdStrictness, mkWorkerId,
                          addIdStrictness, addInlinePragma,
-                         GenId
+                         IdSet, emptyIdSet, addOneToIdSet,
+                         GenId, Id
                        )
 import IdInfo          ( noIdInfo, addUnfoldInfo,  
                          mkStrictnessInfo, addStrictnessInfo, StrictnessInfo(..)
                        )
 import SaLib
-import UniqSupply      ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
+import UniqSupply      ( returnUs, thenUs, mapUs, getUnique, UniqSM )
 import WwLib
+import Outputable
 \end{code}
 
 We take Core bindings whose binders have their strictness attached (by
@@ -185,9 +185,10 @@ tryWW      :: Id                           -- The fn binder
                                        -- wrapper.
 tryWW fn_id rhs
   | (certainlySmallEnoughToInline $
-     calcUnfoldingGuidance (idWantsToBeINLINEd fn_id) 
+     calcUnfoldingGuidance (getInlinePragma fn_id) 
                          opt_UnfoldingCreationThreshold
-                         rhs)
+                         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)
@@ -199,7 +200,7 @@ tryWW fn_id rhs
 
   | otherwise          -- Do w/w split
   = let
-       (uvars, tyvars, wrap_args, body) = collectBinders rhs
+       (tyvars, wrap_args, body) = collectBinders rhs
     in
     mkWwBodies tyvars wrap_args 
               (coreExprType body)
@@ -208,15 +209,15 @@ tryWW fn_id rhs
     let
        work_rhs  = work_fn body
        work_id   = mkWorkerId work_uniq fn_id (coreExprType work_rhs) work_info
-       work_info = noIdInfo `addStrictnessInfo` mkStrictnessInfo work_demands Nothing
+       work_info = noIdInfo `addStrictnessInfo` mkStrictnessInfo work_demands False
 
        wrap_rhs = wrap_fn work_id
        wrap_id  = addInlinePragma (fn_id `addIdStrictness`
-                                   mkStrictnessInfo revised_wrap_args_info (Just work_id))
+                                   mkStrictnessInfo revised_wrap_args_info True)
                -- Add info to the wrapper:
                --      (a) we want to inline it everywhere
                --      (b) we want to pin on its revised stricteness info
-               --      (c) we pin on its worker id
+               --      (c) we pin on its worker id and the list of constructors mentioned in the wrapper
     in
     returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
        -- Worker first, because wrapper mentions it
@@ -229,4 +230,23 @@ tryWW fn_id rhs
     wrap_args_info = case strictness_info of
                        StrictnessInfo args_info _ -> args_info
     revised_wrap_args_info = setUnpackStrategy wrap_args_info
+
+-- This rather (nay! extremely!) crude function looks at a wrapper function, and
+-- snaffles out (a) the worker Id and (b) constructors needed to 
+-- make the wrapper.
+-- These are needed when we write an interface file.
+getWorkerIdAndCons wrap_id wrapper_fn
+  = go wrapper_fn
+  where
+    go (Lam _ body)                      = go body
+    go (Case _ (AlgAlts [(con,_,rhs)] _)) = let (wrap_id, cons) = go rhs
+                                           in  (wrap_id, cons `addOneToIdSet` con)
+    go (Let (NonRec _ (Coerce (CoerceOut con) _ _)) body) 
+                                         = let (wrap_id, cons) = go body
+                                           in  (wrap_id, cons `addOneToIdSet` con)
+    go other                             = (get_work_id other, emptyIdSet)
+
+    get_work_id (App fn _)    = get_work_id fn
+    get_work_id (Var work_id) = work_id
+    get_work_id other        = pprPanic "getWorkerIdAndCons" (ppr wrap_id)
 \end{code}