Eliminate over-zealous warning in CoreToStg

[ghc-hetmet.git] / compiler / stgSyn / CoreToStg.lhs

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 994b900..91c9a20 100644 (file)
--- 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,10 +23,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 )
 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}
@@ -410,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
 
@@ -558,9 +563,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)
 
 
@@ -1067,7 +1078,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
@@ -1077,7 +1087,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.