X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreArity.lhs;h=be34b07014fc2ecb85ce57dc6a6ddbe13ecc4903;hp=d57c895d151befba393ef365c83a56955bc8e087;hb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;hpb=ea84860ef56d72da1f4c63d661b7ad333109237d

diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index d57c895..be34b07 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -8,7 +8,7 @@
 \begin{code}
 -- | Arit and eta expansion
 module CoreArity (
-	manifestArity, exprArity, 
+	manifestArity, exprArity, exprBotStrictness_maybe,
 	exprEtaExpandArity, etaExpand
     ) where
 
@@ -17,7 +17,7 @@ module CoreArity (
 import CoreSyn
 import CoreFVs
 import CoreUtils
-import NewDemand
+import Demand
 import TyCon	( isRecursiveTyCon )
 import qualified CoreSubst
 import CoreSubst ( Subst, substBndr, substBndrs, substExpr
@@ -34,9 +34,6 @@ import Outputable
 import DynFlags
 import StaticFlags	( opt_NoStateHack )
 import FastString
-import Maybes
-
-import GHC.Exts		-- For `xori` 
 \end{code}
 
 %************************************************************************
@@ -141,6 +138,15 @@ exprEtaExpandArity dflags e
     = applyStateHack e (arityType dicts_cheap e)
   where
     dicts_cheap = dopt Opt_DictsCheap dflags
+
+exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
+-- A cheap and cheerful function that identifies bottoming functions
+-- and gives them a suitable strictness signatures.  It's used during
+-- float-out
+exprBotStrictness_maybe e
+  = case arityType False e of
+	AT _ ATop -> Nothing
+	AT a ABot -> Just (a, mkStrictSig (mkTopDmdType (replicate a topDmd) BotRes))
 \end{code}	
 
 Note [Definition of arity]
@@ -276,7 +282,7 @@ applyStateHack e (AT orig_arity is_bot)
 	        1 + go res (arity-1)
           else WARN( arity > 0, ppr arity ) 0
 -}						 
-	| otherwise = WARN( arity > 0, ppr arity ) 0
+	| otherwise = WARN( arity > 0, ppr arity <+> ppr ty) 0
 \end{code}
 
 Note [State hack and bottoming functions]
@@ -355,7 +361,7 @@ trimArity False  (AT _ ATop) = AT 0 ATop	-- Bale out
 ---------------------------
 arityType :: Bool -> CoreExpr -> ArityType
 arityType _ (Var v)
-  | Just strict_sig <- idNewStrictness_maybe v
+  | Just strict_sig <- idStrictness_maybe v
   , (ds, res) <- splitStrictSig strict_sig
   , isBotRes res
   = AT (length ds) ABot	-- Function diverges
@@ -433,6 +439,13 @@ simplification but it's not too hard.  The alernative, of relying on
 a subsequent clean-up phase of the Simplifier to de-crapify the result,
 means you can't really use it in CorePrep, which is painful.
 
+Note [Eta expansion and SCCs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note that SCCs are not treated specially by etaExpand.  If we have
+	etaExpand 2 (\x -> scc "foo" e)
+	= (\xy -> (scc "foo" e) y)
+So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
+
 \begin{code}
 -- | @etaExpand n us e ty@ returns an expression with
 -- the same meaning as @e@, but with arity @n@.
@@ -447,11 +460,6 @@ means you can't really use it in CorePrep, which is painful.
 etaExpand :: Arity	  	-- ^ Result should have this number of value args
 	  -> CoreExpr	        -- ^ Expression to expand
 	  -> CoreExpr
--- Note that SCCs are not treated specially.  If we have
---	etaExpand 2 (\x -> scc "foo" e)
---	= (\xy -> (scc "foo" e) y)
--- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
-
 -- etaExpand deals with for-alls. For example:
 --		etaExpand 1 E
 -- where  E :: forall a. a -> a
@@ -471,7 +479,6 @@ etaExpand n orig_expr
     go 0 expr = expr
     go n (Lam v body) | isTyVar v = Lam v (go n     body)
        	              | otherwise = Lam v (go (n-1) body)
-    go n (Note InlineMe expr) = Note InlineMe (go n expr)
     go n (Cast expr co) = Cast (go n expr) co
     go n expr           = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
        	 		  etaInfoAbs etas (etaInfoApp subst' expr etas)
@@ -624,6 +631,6 @@ freshEtaId n subst ty
         ty'     = substTy subst ty
 	eta_id' = uniqAway (getTvInScope subst) $
 		  mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty'
-	subst'  = extendTvInScope subst [eta_id']		  
+	subst'  = extendTvInScope subst eta_id'		  
 \end{code}