X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FStrictAnal.lhs;h=0a46822835a67823b323629dea28642e8b900563;hb=9d4d03d5f2d75e6c966dc0abdb2b3bc85e384e13;hp=b0c21b452521c16624e8ed1910c3c02683ad9987;hpb=12899612693163154531da3285ec99c1c8ca2226;p=ghc-hetmet.git

diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index b0c21b4..0a46822 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -19,7 +19,7 @@ import CmdLineOpts	( opt_AllStrict, opt_NumbersStrict,
 import CoreSyn
 import Id		( idType, addIdStrictness, isWrapperId,
 			  getIdDemandInfo, addIdDemandInfo,
-			  GenId{-instance Outputable-}
+			  GenId{-instance Outputable-}, SYN_IE(Id)
 			)
 import IdInfo		( mkStrictnessInfo, mkBottomStrictnessInfo,
 			  mkDemandInfo, willBeDemanded, DemandInfo
@@ -27,12 +27,13 @@ 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 UniqSupply       ( UniqSupply )
 import Util		( zipWith4Equal, pprTrace, panic )
 \end{code}
 
@@ -102,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
     )
@@ -123,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}
@@ -404,24 +405,17 @@ addStrictnessInfoToId
 
 addStrictnessInfoToId strflags str_val abs_val binder body
 
-{-		SCHEDULED FOR NUKING 
-  | isWrapperId binder
-  = binder	-- Avoid clobbering existing strictness info
-		-- (and, more importantly, worker info).
-		-- Deeply suspicious (SLPJ)
--}
-
   | isBot str_val
   = binder `addIdStrictness` mkBottomStrictnessInfo
 
   | otherwise
-  = 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
-    }
+  = 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}