X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fstranal%2FWwLib.lhs;h=faffff296f0a46992f7fbe0143ab16cac1419e93;hb=83a8fc9f6e04436784693a2188a58eac9c3e9664;hp=a7050dc0d0166ce643c8f7b5682d03f6e7a0f122;hpb=9ffadf219cbc4f8ec57264786df936a3cee88aec;p=ghc-hetmet.git

diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index a7050dc..faffff2 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -10,20 +10,21 @@ module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs ) where
 
 import CoreSyn
 import CoreUtils	( exprType )
-import Id		( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo,
+import Id		( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
 			  isOneShotLambda, setOneShotLambda, setIdUnfolding,
                           setIdInfo
 			)
 import IdInfo		( vanillaIdInfo )
 import DataCon
-import NewDemand	( Demand(..), DmdResult(..), Demands(..) ) 
-import MkId		( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID,
+import Demand		( Demand(..), DmdResult(..), Demands(..) ) 
+import MkCore		( mkRuntimeErrorApp, aBSENT_ERROR_ID )
+import MkId		( realWorldPrimId, voidArgId, 
                           mkUnpackCase, mkProductBox )
 import TysWiredIn	( tupleCon )
 import Type
 import Coercion         ( mkSymCoercion, splitNewTypeRepCo_maybe )
 import BasicTypes	( Boxity(..) )
-import Var              ( Var, isId )
+import Var              ( Var )
 import UniqSupply
 import Unique
 import Util		( zipWithEqual )
@@ -133,8 +134,8 @@ mkWwBodies fun_ty demands res_info one_shots
 	             return (id, id, res_ty)
 
 	; let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty
-	; return ([idNewDemandInfo v | v <- work_call_args, isId v],
-                  Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
+	; return ([idDemandInfo v | v <- work_call_args, isId v],
+                  wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
                   mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) }
         -- We use an INLINE unconditionally, even if the wrapper turns out to be
         -- something trivial like
@@ -278,9 +279,9 @@ mkWWargs subst fun_ty arg_info
 applyToVars :: [Var] -> CoreExpr -> CoreExpr
 applyToVars vars fn = mkVarApps fn vars
 
-mk_wrap_arg :: Unique -> Type -> NewDemand.Demand -> Bool -> Id
+mk_wrap_arg :: Unique -> Type -> Demand -> Bool -> Id
 mk_wrap_arg uniq ty dmd one_shot 
-  = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd)
+  = set_one_shot one_shot (setIdDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd)
   where
     set_one_shot True  id = setOneShotLambda id
     set_one_shot False id = id
@@ -336,17 +337,16 @@ mkWWstr (arg : args) = do
 --	  brings into scope wrap_arg (via lets)
 mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
 mkWWstr_one arg
-  | isTyVar arg
+  | isTyCoVar arg
   = return ([arg],  nop_fn, nop_fn)
 
   | otherwise
-  = case idNewDemandInfo arg of
+  = case idDemandInfo arg of
 
 	-- Absent case.  We don't deal with absence for unlifted types,
 	-- though, because it's not so easy to manufacture a placeholder
 	-- We'll see if this turns out to be a problem
-      Abs | not (isUnLiftedType (idType arg)) ->
-	return ([], nop_fn, mk_absent_let arg) 
+      Abs -> return ([], nop_fn, mk_absent_let arg) 
 
 	-- Unpack case
       Eval (Prod cs)
@@ -392,7 +392,7 @@ mkWWstr_one arg
 	-- If the wrapper argument is a one-shot lambda, then
 	-- so should (all) the corresponding worker arguments be
 	-- This bites when we do w/w on a case join point
-    set_worker_arg_info worker_arg demand = set_one_shot (setIdNewDemandInfo worker_arg demand)
+    set_worker_arg_info worker_arg demand = set_one_shot (setIdDemandInfo worker_arg demand)
 
     set_one_shot | isOneShotLambda arg = setOneShotLambda
 		 | otherwise	       = \x -> x
@@ -493,17 +493,29 @@ workerCase bndr e args con body = mkUnpackCase bndr e args con body
 %************************************************************************
 
 
+Note [Absent error Id]
+~~~~~~~~~~~~~~~~~~~~~~
+We make a new binding for Ids that are marked absent, thus
+   let x = absentError "x :: Int"
+The idea is that this binding will never be used; but if it 
+buggily is used we'll get a runtime error message.
+
+We do this even for *unlifted* types (e.g. Int#).  We define
+absentError to *not* be a bottoming Id, and we treat it as
+"ok for speculation" (see CoreUtils.okForSpeculation). That
+means that the let won't get turned into a case, and will
+be discarded if (as we fully expect) x turns out to be dead.
+Coping with absence for unlifted types is important; see, for
+example, Trac #4306.
+
 \begin{code}
 mk_absent_let :: Id -> CoreExpr -> CoreExpr
 mk_absent_let arg body
-  | not (isUnLiftedType arg_ty)
   = Let (NonRec arg abs_rhs) body
-  | otherwise
-  = panic "WwLib: haven't done mk_absent_let for primitives yet"
   where
-    arg_ty = idType arg
-    abs_rhs = mkRuntimeErrorApp rUNTIME_ERROR_ID arg_ty msg
-    msg     = "Oops!  Entered absent arg " ++ showSDocDebug (ppr arg <+> ppr (idType arg))
+    arg_ty  = idType arg
+    abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
+    msg     = showSDocDebug (ppr arg <+> ppr (idType arg))
 
 mk_seq_case :: Id -> CoreExpr -> CoreExpr
 mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]