projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
allow build settings to be overriden by adding mk/validate.mk
[ghc-hetmet.git]
/
compiler
/
stgSyn
/
CoreToStg.lhs
diff --git
a/compiler/stgSyn/CoreToStg.lhs
b/compiler/stgSyn/CoreToStg.lhs
index
64f9fe3
..
a50a45e
100644
(file)
--- a/
compiler/stgSyn/CoreToStg.lhs
+++ b/
compiler/stgSyn/CoreToStg.lhs
@@
-16,10
+16,9
@@
import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault )
import StgSyn
import Type
import StgSyn
import Type
-import TyCon ( isAlgTyCon )
+import TyCon
import Id
import Var ( Var, globalIdDetails, idType )
import Id
import Var ( Var, globalIdDetails, idType )
-import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
import IdInfo
import DataCon
import CostCentre ( noCCS )
import IdInfo
import DataCon
import CostCentre ( noCCS )
@@
-317,15
+316,11
@@
coreToStgExpr (Note (SCC cc) expr)
= coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
returnLne (StgSCC cc expr2, fvs, escs) )
= 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) )
= 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
coreToStgExpr (Note other_note expr)
= coreToStgExpr expr
@@
-414,10
+409,11
@@
coreToStgExpr (Let bind body)
mkStgAltType scrut_ty alts
= case splitTyConApp_maybe (repType scrut_ty) of
Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
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
| 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
| otherwise -> pprPanic "mkStgAlts" (ppr tc)
Nothing -> PolyAlt
@@
-451,6
+447,7
@@
coreToStgApp
-> [CoreArg] -- Arguments
-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
-> [CoreArg] -- Arguments
-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
+
coreToStgApp maybe_thunk_body f args
= coreToStgArgs args `thenLne` \ (args', args_fvs) ->
lookupVarLne f `thenLne` \ how_bound ->
coreToStgApp maybe_thunk_body f args
= coreToStgArgs args `thenLne` \ (args', args_fvs) ->
lookupVarLne f `thenLne` \ how_bound ->
@@
-508,6
+505,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
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
_other -> StgApp f args'
in
@@
-1098,8
+1096,6
@@
myCollectBinders expr
where
go bs (Lam b e) = go (b:bs) e
go bs e@(Note (SCC _) _) = (reverse bs, e)
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)
go bs (Cast e co) = go bs e
go bs (Note _ e) = go bs e
go bs e = (reverse bs, e)
@@
-1113,8
+1109,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 (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)
go (Cast e co) as = go e as
go (Note n e) as = go e as
go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)