Comment out deeply suspicious (and unused) function insertStableSymbol

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

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 31837b9..64f9fe3 100644 (file)
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -16,7 +16,6 @@ import CoreUtils      ( rhsIsStatic, manifestArity, exprType, findDefault )
 import StgSyn
 
 import Type
-import Coercion         ( mkUnsafeCoercion )
 import TyCon           ( isAlgTyCon )
 import Id
 import Var             ( Var, globalIdDetails, idType )
@@ -318,6 +317,15 @@ coreToStgExpr (Note (SCC cc) expr)
   = coreToStgExpr expr         `thenLne` ( \ (expr2, fvs, escs) ->
     returnLne (StgSCC cc expr2, fvs, escs) )
 
+coreToStgExpr (Note (TickBox m n) expr)
+  = coreToStgExpr expr         `thenLne` ( \ (expr2, fvs, escs) ->
+    returnLne (StgTick m n expr2, fvs, escs) )
+
+-- BinaryTickBox'es are are removed by the CorePrep pass.
+
+coreToStgExpr expr@(Note (BinaryTickBox m t e) _)      
+  = pprPanic "coreToStgExpr: " (ppr expr)
+
 coreToStgExpr (Note other_note expr)
   = coreToStgExpr expr
 
@@ -496,8 +504,8 @@ 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
                _other           -> StgApp f args'
@@ -540,6 +548,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)
 
 
@@ -1075,6 +1098,8 @@ myCollectBinders expr
   where
     go bs (Lam b e)          = go (b:bs) e
     go bs e@(Note (SCC _) _) = (reverse bs, e) 
+    go bs e@(Note (TickBox {}) _) = (reverse bs, e)
+    go bs e@(Note (BinaryTickBox {}) _)  = (reverse bs, e)
     go bs (Cast e co)        = go bs e
     go bs (Note _ e)         = go bs e
     go bs e                 = (reverse bs, e)
@@ -1088,6 +1113,8 @@ 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 (Note (TickBox {}) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+    go (Note (BinaryTickBox {}) 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)