[project @ 2003-06-03 09:41:48 by ross]

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

diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index 3e83e22..d143a15 100644 (file)
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -7,25 +7,30 @@ The original version(s) of all strictness-analyser code (except the
 Semantique analyser) was written by Andy Gill.
 
 \begin{code}
+#ifndef OLD_STRICTNESS
+module StrictAnal ( ) where
+
+#else
+
 module StrictAnal ( saBinds ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( opt_D_dump_stranal, opt_D_dump_simpl_stats,  opt_D_verbose_core2core )
+import CmdLineOpts     ( DynFlags, DynFlag(..) )
 import CoreSyn
-import Id              ( idType, setIdStrictness, setInlinePragma, 
+import Id              ( setIdStrictness, setInlinePragma, 
                          idDemandInfo, setIdDemandInfo, isBottomingId,
                          Id
                        )
-import IdInfo          ( InlinePragInfo(..) )
-import CoreLint                ( beginPass, endPass )
-import ErrUtils                ( dumpIfSet )
+import CoreLint                ( showPass, endPass )
+import ErrUtils                ( dumpIfSet_dyn )
 import SaAbsInt
 import SaLib
 import Demand          ( Demand, wwStrict, isStrict, isLazy )
-import UniqSupply       ( UniqSupply )
-import Util            ( zipWith3Equal, stretchZipWith )
+import Util            ( zipWith3Equal, stretchZipWith, compareLength )
+import BasicTypes      ( Activation( NeverActive ) )
 import Outputable
+import FastTypes
 \end{code}
 
 %************************************************************************
@@ -79,23 +84,22 @@ worker-wrapper pass can use this info to create wrappers and
 strict workers.
 
 \begin{code}
-saBinds ::[CoreBind]
-          -> IO [CoreBind]
-
-saBinds binds
+saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
+saBinds dflags binds
   = do {
-       beginPass "Strictness analysis";
+       showPass dflags "Strictness analysis";
 
        -- Mark each binder with its strictness
 #ifndef OMIT_STRANAL_STATS
        let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
-       dumpIfSet opt_D_dump_simpl_stats "Strictness analysis statistics"
+       dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics"
                  (pp_stats sa_stats);
 #else
        let { binds_w_strictness = saTopBindsBinds binds };
 #endif
 
-       endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds_w_strictness
+       endPass dflags "Strictness analysis" Opt_D_dump_stranal
+               binds_w_strictness
     }
 \end{code}
 
@@ -186,12 +190,12 @@ saTopBind str_env abs_env (Rec pairs)
     in
     returnSa (new_str_env, new_abs_env, Rec new_pairs)
 
+-- Hack alert!
 -- Top level divergent bindings are marked NOINLINE
 -- This avoids fruitless inlining of top level error functions
 addStrictnessInfoToTopId str_val abs_val bndr
   = if isBottomingId new_id then
-       new_id `setInlinePragma` IMustNotBeINLINEd False Nothing
-               -- This is a NOINLINE pragma
+       new_id `setInlinePragma` NeverActive
     else
        new_id
   where
@@ -228,7 +232,9 @@ saApp str_env abs_env (fun, args)
   where
     arg_dmds = case fun of
                 Var var -> case lookupAbsValEnv str_env var of
-                               Just (AbsApproxFun ds _) | length ds >= length args 
+                               Just (AbsApproxFun ds _) 
+                                  | compareLength ds args /= LT 
+                                             -- 'ds' is at least as long as 'args'.
                                        -> ds ++ minDemands
                                other   -> minDemands
                 other -> minDemands
@@ -391,12 +397,12 @@ addDemandInfoToCaseBndr dmd str_env abs_env alts binder
 
 \begin{code}
 data SaStats
-  = SaStats FAST_INT FAST_INT  -- total/marked-demanded lambda-bound
-           FAST_INT FAST_INT   -- total/marked-demanded case-bound
-           FAST_INT FAST_INT   -- total/marked-demanded let-bound
+  = SaStats FastInt FastInt    -- total/marked-demanded lambda-bound
+           FastInt FastInt     -- total/marked-demanded case-bound
+           FastInt FastInt     -- total/marked-demanded let-bound
                                -- (excl. top-level; excl. letrecs)
 
-nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
+nullSaStats = SaStats (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0)
 
 thenSa       :: SaM a -> (a -> SaM b) -> SaM b
 thenSa_              :: SaM a -> SaM b -> SaM b
@@ -424,16 +430,22 @@ thenSa_ expr cont stats
 returnSa x stats = (x, stats)
 
 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
-  = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
-    ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
+  = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
+    let tot = iUnbox totB ; demanded = iUnbox demandedB 
+    in
+    ((), SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet) }
 
 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
-  = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
-    ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
+  = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) ->
+    let tot = iUnbox totB ; demanded = iUnbox demandedB 
+    in
+    ((), SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet) }
 
 tickLet var (SaStats tlam dlam tc dc tlet dlet)
-  = case (tick_demanded var (0,0))        of { (IBOX(tot),IBOX(demanded)) ->
-    ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
+  = case (tick_demanded var (0,0))        of { (totB, demandedB) ->
+    let tot = iUnbox totB ; demanded = iUnbox demandedB 
+    in
+    ((), SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded)) }
 
 tick_demanded var (tot, demanded)
   | isTyVar var = (tot, demanded)
@@ -444,12 +456,12 @@ tick_demanded var (tot, demanded)
      else demanded)
 
 pp_stats (SaStats tlam dlam tc dc tlet dlet)
-      = hcat [ptext SLIT("Lambda vars: "), int IBOX(dlam), char '/', int IBOX(tlam),
-                   ptext SLIT("; Case vars: "), int IBOX(dc),   char '/', int IBOX(tc),
-                   ptext SLIT("; Let vars: "),  int IBOX(dlet), char '/', int IBOX(tlet)
+      = hcat [ptext SLIT("Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
+             ptext SLIT("; Case vars: "), int (iBox dc),   char '/', int (iBox tc),
+             ptext SLIT("; Let vars: "),  int (iBox dlet), char '/', int (iBox tlet)
        ]
 
-#else {-OMIT_STRANAL_STATS-}
+#else /* OMIT_STRANAL_STATS */
 -- identity monad
 type SaM a = a
 
@@ -463,7 +475,7 @@ tickLambda var  = panic "OMIT_STRANAL_STATS: tickLambda"
 tickCases  vars = panic "OMIT_STRANAL_STATS: tickCases"
 tickLet    var  = panic "OMIT_STRANAL_STATS: tickLet"
 
-#endif {-OMIT_STRANAL_STATS-}
+#endif /* OMIT_STRANAL_STATS */
 
 mapSa        :: (a -> SaM b) -> [a] -> SaM [b]
 
@@ -477,4 +489,6 @@ sequenceSa []     = returnSa []
 sequenceSa (m:ms) = m            `thenSa` \ r ->
                    sequenceSa ms `thenSa` \ rs ->
                    returnSa (r:rs)
+
+#endif /* OLD_STRICTNESS */
 \end{code}