X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FstgSyn%2FCoreToStg.lhs;h=51e830c2e80699ab94209b19e14e10b7c117f6bd;hp=31837b904362416695b1ca620058eabbcd0e5ca3;hb=1a7d1b77334529ca96ed4cbc03fcb5f55dc2de4a;hpb=fb38b8bab2b531ca7ac4ea28ad5b259a00e3759b

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 31837b9..51e830c 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -7,6 +7,13 @@ And, as we have the info in hand, we may convert some lets to
 let-no-escapes.
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module CoreToStg ( coreToStg, coreExprToStg ) where
 
 #include "HsVersions.h"
@@ -16,11 +23,9 @@ import CoreUtils	( rhsIsStatic, manifestArity, exprType, findDefault )
 import StgSyn
 
 import Type
-import Coercion         ( mkUnsafeCoercion )
-import TyCon		( isAlgTyCon )
+import TyCon
 import Id
 import Var		( Var, globalIdDetails, idType )
-import TyCon		( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
 import IdInfo
 import DataCon
 import CostCentre	( noCCS )
@@ -31,7 +36,7 @@ import Name		( getOccName, isExternalName, nameOccName )
 import OccName		( occNameString, occNameFS )
 import BasicTypes       ( Arity )
 import StaticFlags	( opt_RuntimeTypes )
-import PackageConfig	( PackageId )
+import Module
 import Outputable
 
 infixr 9 `thenLne`
@@ -210,7 +215,6 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs)
     ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
     (env', fvs' `unionFVInfo` body_fvs, bind)
 
-#ifdef DEBUG
 -- Assertion helper: this checks that the CafInfo on the Id matches
 -- what CoreToStg has figured out about the binding's SRT.  The
 -- CafInfo will be exact in all cases except when CorePrep has
@@ -225,7 +229,6 @@ consistentCafInfo id bind
 	exact = id_marked_caffy == binding_is_caffy
 	id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
 	binding_is_caffy = stgBindHasCafRefs bind
-#endif
 \end{code}
 
 \begin{code}
@@ -318,6 +321,11 @@ coreToStgExpr (Note (SCC cc) expr)
   = coreToStgExpr expr		`thenLne` ( \ (expr2, fvs, escs) ->
     returnLne (StgSCC cc expr2, fvs, escs) )
 
+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
 
@@ -406,10 +414,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
 
@@ -443,6 +452,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 ->
@@ -496,10 +506,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
@@ -540,6 +551,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)
 
 
@@ -1046,7 +1072,6 @@ plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
   = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
     (id1, hb1, combineStgBinderInfo info1 info2)
 
-#ifdef DEBUG
 -- The HowBound info for a variable in the FVInfo should be consistent
 check_eq_how_bound ImportBound 	      ImportBound 	 = True
 check_eq_how_bound LambdaBound 	      LambdaBound 	 = True
@@ -1056,7 +1081,6 @@ check_eq_how_bound hb1		      hb2		 = False
 check_eq_li (NestedLet _) (NestedLet _) = True
 check_eq_li TopLet        TopLet        = True
 check_eq_li li1 	  li2		= False
-#endif
 \end{code}
 
 Misc.