X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FstgSyn%2FCoreToStg.lhs;h=a50a45ee36636a949660e28aec97c2062363d257;hb=8a2809c29de9f23eba7ca682b48390033a9d40f6;hp=50b2973ed5d45cb6fc127be21d27a752df41cc9a;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 50b2973..a50a45e 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -16,13 +16,9 @@ import CoreUtils	( rhsIsStatic, manifestArity, exprType, findDefault )
 import StgSyn
 
 import Type
-import TyCon		( isAlgTyCon )
+import TyCon
 import Id
 import Var		( Var, globalIdDetails, idType )
-import TyCon		( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
-#ifdef ILX
-import MkId		( unsafeCoerceId )
-#endif
 import IdInfo
 import DataCon
 import CostCentre	( noCCS )
@@ -185,7 +181,7 @@ coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
 	
 	bind = StgNonRec id stg_rhs
     in
-    ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)
+    ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id $$ (ptext SLIT("rhs:")) <+> ppr rhs $$ (ptext SLIT("stg_rhs:"))<+> ppr stg_rhs $$ (ptext SLIT("Manifest:")) <+> (ppr $ manifestArity rhs) $$ (ptext SLIT("STG:")) <+>(ppr $ stgRhsArity stg_rhs) )
     ASSERT2(consistentCafInfo id bind, ppr id)
 --    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
     (env', fvs' `unionFVInfo` body_fvs, bind)
@@ -320,18 +316,17 @@ coreToStgExpr (Note (SCC cc) expr)
   = coreToStgExpr expr		`thenLne` ( \ (expr2, fvs, escs) ->
     returnLne (StgSCC cc expr2, fvs, escs) )
 
-#ifdef ILX
--- For ILX, convert (__coerce__ to_ty from_ty e) 
---	    into    (coerce to_ty from_ty e)
--- where coerce is real function
-coreToStgExpr (Note (Coerce to_ty from_ty) expr)
-  = coreToStgExpr (mkApps (Var unsafeCoerceId) 
-			  [Type from_ty, Type to_ty, expr])
-#endif
+coreToStgExpr (Case (Var id) _bndr ty [(DEFAULT,[],expr)])
+  | Just (TickBox m n) <- isTickBoxOp_maybe id
+  = coreToStgExpr expr         `thenLne` ( \ (expr2, fvs, escs) ->
+    returnLne (StgTick m n expr2, fvs, escs) )
 
 coreToStgExpr (Note other_note expr)
   = coreToStgExpr expr
 
+coreToStgExpr (Cast expr co)
+  = coreToStgExpr expr
+
 -- Cases require a little more real work.
 
 coreToStgExpr (Case scrut bndr _ alts)
@@ -414,10 +409,11 @@ coreToStgExpr (Let bind body)
 mkStgAltType scrut_ty alts
   = case splitTyConApp_maybe (repType scrut_ty) of
 	Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
-		    | isPrimTyCon tc	     -> PrimAlt tc
+		    | isUnLiftedTyCon tc     -> PrimAlt tc
 		    | isHiBootTyCon tc	     -> look_for_better_tycon
 		    | isAlgTyCon tc 	     -> AlgAlt tc
 		    | isFunTyCon tc	     -> PolyAlt
+                    | isPrimTyCon tc         -> PolyAlt -- for "Any"
 		    | otherwise		     -> pprPanic "mkStgAlts" (ppr tc)
 	Nothing				     -> PolyAlt
 
@@ -451,6 +447,7 @@ coreToStgApp
 	-> [CoreArg]			-- Arguments
 	-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
 
+
 coreToStgApp maybe_thunk_body f args
   = coreToStgArgs args		`thenLne` \ (args', args_fvs) ->
     lookupVarLne f		`thenLne` \ how_bound ->
@@ -504,10 +501,11 @@ coreToStgApp maybe_thunk_body f args
 	res_ty = exprType (mkApps (Var f) args)
 	app = case globalIdDetails f of
       		DataConWorkId dc | saturated -> StgConApp dc args'
-	        PrimOpId op  		     -> ASSERT( saturated )
-					        StgOpApp (StgPrimOp op) args' res_ty
+	        PrimOpId op  	 -> ASSERT( saturated )
+				    StgOpApp (StgPrimOp op) args' res_ty
 		FCallId call	 -> ASSERT( saturated )
 				    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
 		_other      	 -> StgApp f args'
 
     in
@@ -548,6 +546,21 @@ coreToStgArgs (arg : args)	-- Non-type argument
 		       StgLit lit       -> StgLitArg lit
 		       _ 		-> pprPanic "coreToStgArgs" (ppr arg)
     in
+	-- WARNING: what if we have an argument like (v `cast` co)
+	-- 	    where 'co' changes the representation type?
+	--	    (This really only happens if co is unsafe.)
+	-- Then all the getArgAmode stuff in CgBindery will set the
+	-- cg_rep of the CgIdInfo based on the type of v, rather
+	-- than the type of 'co'.
+	-- This matters particularly when the function is a primop
+	-- or foreign call.
+	-- Wanted: a better solution than this hacky warning
+    let
+	arg_ty = exprType arg
+	stg_arg_ty = stgArgType stg_arg
+    in
+    WARN( isUnLiftedType arg_ty /= isUnLiftedType stg_arg_ty, 
+	  ptext SLIT("Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg)
     returnLne (stg_arg : stg_args, fvs)
 
 
@@ -1083,6 +1096,7 @@ myCollectBinders expr
   where
     go bs (Lam b e)          = go (b:bs) e
     go bs e@(Note (SCC _) _) = (reverse bs, e) 
+    go bs (Cast e co)        = go bs e
     go bs (Note _ e)         = go bs e
     go bs e	             = (reverse bs, e)
 
@@ -1095,6 +1109,7 @@ myCollectArgs expr
     go (Var v)          as = (v, as)
     go (App f a) as        = go f (a:as)
     go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+    go (Cast e co)      as = go e as
     go (Note n e)       as = go e as
     go _		as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
 \end{code}