X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FstgSyn%2FCoreToStg.lhs;h=94b0dd3f8e17baf4175afe964b9b7ac913f38260;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hp=64f9fe3ad3b5f153ec6b5bfb23b58f682f46e8f5;hpb=6ef2fc2ebf11755a54386f8e317d83cb19913be1;p=ghc-hetmet.git

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 64f9fe3..94b0dd3 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/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 )
@@ -317,15 +323,11 @@ coreToStgExpr (Note (SCC cc) expr)
   = coreToStgExpr expr		`thenLne` ( \ (expr2, fvs, escs) ->
     returnLne (StgSCC cc expr2, fvs, escs) )
 
-coreToStgExpr (Note (TickBox m n) expr)
+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) )
 
--- 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
 
@@ -414,10 +416,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 +454,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 ->
@@ -508,6 +512,7 @@ coreToStgApp maybe_thunk_body f args
 				    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
@@ -1098,8 +1103,6 @@ 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)
@@ -1113,8 +1116,6 @@ 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)