X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FstgSyn%2FCoreToStg.lhs;h=40023bf36347ee0f5fe78248d01c0383a17ee8c8;hb=9ee6397787a1400c63e3d807de5996ca6ee9ecc8;hp=614feba45db739afb87af582745d1ccd0a7e793d;hpb=fd8f8c6a4d1d5a91c0095804a9ada86c42d64141;p=ghc-hetmet.git

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 614feba..40023bf 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"
@@ -19,7 +26,6 @@ import Type
 import TyCon
 import Id
 import Var		( Var, globalIdDetails, idType )
-import TyCon		( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
 import IdInfo
 import DataCon
 import CostCentre	( noCCS )
@@ -30,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`
@@ -209,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
@@ -224,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}
@@ -367,7 +371,7 @@ coreToStgExpr (Case scrut bndr _ alts)
 		     (getLiveVars alts_lv_info)
 		     bndr'
 		     (mkSRT alts_lv_info)
-		     (mkStgAltType (idType bndr) alts)
+		     (mkStgAltType bndr alts)
 		     alts2,
       scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
       alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
@@ -407,21 +411,27 @@ coreToStgExpr (Let bind body)
 \end{code}
 
 \begin{code}
-mkStgAltType scrut_ty alts
-  = case splitTyConApp_maybe (repType scrut_ty) of
+mkStgAltType bndr alts
+  = case splitTyConApp_maybe (repType (idType bndr)) of
 	Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt 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)
+		    | otherwise		     -> ASSERT( _is_poly_alt_tycon tc )
+						PolyAlt
 	Nothing				     -> PolyAlt
 
   where
-   -- Sometimes, the TyCon in the type of the scrutinee is an HiBootTyCon,
-   -- which may not have any constructors inside it.  If so, then we
-   -- can get a better TyCon by grabbing the one from a constructor alternative
+   _is_poly_alt_tycon tc
+	=  isFunTyCon tc
+        || isPrimTyCon tc   -- "Any" is lifted but primitive
+	|| isOpenTyCon tc   -- Type family; e.g. arising from strict
+			    -- function application where argument has a
+			    -- type-family type
+
+   -- Sometimes, the TyCon is a HiBootTyCon which may not have any 
+   -- constructors inside it.  Then we can get a better TyCon by 
+   -- grabbing the one from a constructor alternative
    -- if one exists.
    look_for_better_tycon
 	| ((DataAlt con, _, _) : _) <- data_alts = 
@@ -559,9 +569,15 @@ coreToStgArgs (arg : args)	-- Non-type argument
     let
 	arg_ty = exprType arg
 	stg_arg_ty = stgArgType stg_arg
+	bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty)) 
+		|| (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
+	-- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted), 
+	-- and pass it to a function expecting an HValue (arg_ty).  This is ok because
+	-- we can treat an unlifted value as lifted.  But the other way round 
+	-- we complain.
+	-- We also want to check if a pointer is cast to a non-ptr etc
     in
-    WARN( isUnLiftedType arg_ty /= isUnLiftedType stg_arg_ty, 
-	  ptext SLIT("Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg)
+    WARN( bad_args, ptext SLIT("Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
     returnLne (stg_arg : stg_args, fvs)
 
 
@@ -1068,7 +1084,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
@@ -1078,7 +1093,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.