[project @ 1997-05-18 23:04:57 by sof]

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

diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index 71c6e90..0a46822 100644 (file)
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -11,15 +11,15 @@ Semantique analyser) was written by Andy Gill.
 
 module StrictAnal ( saWwTopBinds, saTopBinds ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
 import CmdLineOpts     ( opt_AllStrict, opt_NumbersStrict,
                          opt_D_dump_stranal, opt_D_simplifier_stats
                        )
 import CoreSyn
-import Id              ( idType, addIdStrictness,
+import Id              ( idType, addIdStrictness, isWrapperId,
                          getIdDemandInfo, addIdDemandInfo,
-                         GenId{-instance Outputable-}
+                         GenId{-instance Outputable-}, SYN_IE(Id)
                        )
 import IdInfo          ( mkStrictnessInfo, mkBottomStrictnessInfo,
                          mkDemandInfo, willBeDemanded, DemandInfo
@@ -27,18 +27,16 @@ import IdInfo               ( mkStrictnessInfo, mkBottomStrictnessInfo,
 import PprCore         ( pprCoreBinding, pprBigCoreBinder )
 import PprStyle                ( PprStyle(..) )
 import PprType         ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
-import Pretty          ( ppBesides, ppStr, ppInt, ppChar, ppAboves )
+import Pretty          ( Doc, hcat, ptext, int, char, vcat )
 import SaAbsInt
 import SaLib
 import TyVar           ( GenTyVar{-instance Eq-} )
 import WorkWrap                -- "back-end" of strictness analyser
 import Unique          ( Unique{-instance Eq -} )
-import Util            ( zipWith4Equal, pprTrace, panic{-ToDo:rm-} )
-
-isWrapperId = panic "StrictAnal.isWrapperId (ToDo)"
+import UniqSupply       ( UniqSupply )
+import Util            ( zipWith4Equal, pprTrace, panic )
 \end{code}
 
-
 %************************************************************************
 %*                                                                     *
 \subsection[Thoughts]{Random thoughts}
@@ -105,7 +103,7 @@ saWwTopBinds us binds
     in
     -- possibly show what we decided about strictness...
     (if opt_D_dump_stranal
-     then pprTrace "Strictness:\n" (ppAboves (
+     then pprTrace "Strictness:\n" (vcat (
           map (pprCoreBinding PprDebug)  binds_w_strictness))
      else id
     )
@@ -126,9 +124,9 @@ saWwTopBinds us binds
   where
     pp_stats (SaStats tlam dlam tc dc tlet dlet)
       = pprTrace "Binders marked demanded: "
-       (ppBesides [ppStr "Lambda vars: ", ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam),
-                 ppStr "; Case vars: ",   ppInt IBOX(dc),   ppChar '/', ppInt IBOX(tc),
-                 ppStr "; Let vars: ",    ppInt IBOX(dlet), ppChar '/', ppInt 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)
        ])
 #endif
 \end{code}
@@ -406,21 +404,18 @@ addStrictnessInfoToId
        -> Id                   -- Augmented with strictness
 
 addStrictnessInfoToId strflags str_val abs_val binder body
-  = if isWrapperId binder then
-       binder  -- Avoid clobbering existing strictness info
-               -- (and, more importantly, worker info).
-               -- Deeply suspicious (SLPJ)
-    else
-    if (isBot str_val) then
-       binder `addIdStrictness` mkBottomStrictnessInfo
-    else
-       case (collectBinders body) of { (_, _, lambda_bounds, rhs) ->
-       let
-               tys        = map idType lambda_bounds
-               strictness = findStrictness strflags tys str_val abs_val
-       in
-       binder `addIdStrictness` mkStrictnessInfo strictness Nothing
-       }
+
+  | isBot str_val
+  = binder `addIdStrictness` mkBottomStrictnessInfo
+
+  | otherwise
+  = case (collectBinders body) of
+       (_, _, [], rhs)            -> binder
+       (_, _, lambda_bounds, rhs) -> binder `addIdStrictness` 
+                                     mkStrictnessInfo strictness Nothing
+               where
+                   tys        = map idType lambda_bounds
+                   strictness = findStrictness strflags tys str_val abs_val
 \end{code}
 
 \begin{code}