isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
isBottomingId, idIsFrom,
+ isTickBoxOp, isTickBoxOp_maybe,
hasNoBinding,
-- Inline pragma stuff
| otherwise = False -- TyVars count as not dead
\end{code}
+\begin{code}
+isTickBoxOp :: Id -> Bool
+isTickBoxOp id =
+ case globalIdDetails id of
+ TickBoxOpId tick -> True
+ _ -> False
+
+isTickBoxOp_maybe :: Id -> Maybe TickBoxOp
+isTickBoxOp_maybe id =
+ case globalIdDetails id of
+ TickBoxOpId tick -> Just tick
+ _ -> Nothing
+\end{code}
%************************************************************************
%* *
CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs,
-- Lambda-bound variable info
- LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo
+ LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo,
+
+ -- Tick-box info
+ TickBoxOp(..), TickBoxId,
) where
#include "HsVersions.h"
import ForeignCall
import NewDemand
import Outputable
+import Module
import Data.Maybe
%************************************************************************
%* *
-\subsection{GlobalIdDetails
+\subsection{GlobalIdDetails}
%* *
%************************************************************************
| PrimOpId PrimOp -- The Id for a primitive operator
| FCallId ForeignCall -- The Id for a foreign call
+ | TickBoxOpId TickBoxOp -- The Id for a tick box (both traditional and binary)
+
| NotGlobalId -- Used as a convenient extra return value from globalIdDetails
notGlobalId = NotGlobalId
ppr (ClassOpId _) = ptext SLIT("[ClassOp]")
ppr (PrimOpId _) = ptext SLIT("[PrimOp]")
ppr (FCallId _) = ptext SLIT("[ForeignCall]")
+ ppr (TickBoxOpId _) = ptext SLIT("[TickBoxOp]")
ppr (RecordSelId {}) = ptext SLIT("[RecSel]")
\end{code}
zapFragileInfo info = Just (info `setSpecInfo` emptySpecInfo
`setUnfoldingInfo` NoUnfolding)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{TickBoxOp}
+%* *
+%************************************************************************
+
+\begin{code}
+type TickBoxId = Int
+
+data TickBoxOp
+ = TickBox Module !TickBoxId -- ^Tick box for Hpc-style coverage,
+ -- type = State# Void#
+ | BinaryTickBox Module !TickBoxId !TickBoxId
+ -- ^Binary tick box, with a tick for result = True, result = False,
+ -- type = Bool -> Bool
+instance Outputable TickBoxOp where
+ ppr (TickBox mod n) = ptext SLIT("tick") <+> ppr (mod,n)
+ ppr (BinaryTickBox mod t f) = ptext SLIT("btick") <+> ppr (mod,t,f)
+\end{code}
mkDataConIds,
mkRecordSelId,
- mkPrimOpId, mkFCallId,
+ mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBinaryTickBoxOpId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
mkUnpackCase, mkProductBox,
import Outputable
import FastString
import ListSetOps
+import Module
\end{code}
%************************************************************************
(arg_tys, _) = tcSplitFunTys tau
arity = length arg_tys
strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
+
+mkTickBoxOpId :: Unique
+ -> Module
+ -> TickBoxId
+ -> Id
+mkTickBoxOpId uniq mod ix = mkGlobalId (TickBoxOpId tickbox) name ty info
+ where
+ tickbox = TickBox mod ix
+ occ_str = showSDoc (braces (ppr tickbox))
+ name = mkTickBoxOpName uniq occ_str
+ info = noCafIdInfo
+ ty = realWorldStatePrimTy
+
+mkBinaryTickBoxOpId
+ :: Unique
+ -> Module
+ -> TickBoxId
+ -> TickBoxId
+ -> Id
+mkBinaryTickBoxOpId uniq mod ixT ixF = mkGlobalId (TickBoxOpId tickbox) name ty info
+ where
+ tickbox = BinaryTickBox mod ixT ixF
+ occ_str = showSDoc (braces (ppr tickbox))
+ name = mkTickBoxOpName uniq occ_str
+ info = noCafIdInfo
+ `setArityInfo` arity
+ `setAllStrictnessInfo` Just strict_sig
+ ty = mkFunTy boolTy boolTy
+
+ arity = 1
+ strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
+ --- ?? mkStrictSig (mkTopDmdType [seqDmd] TopRes)
\end{code}
mkInternalName, mkSystemName,
mkSystemVarName, mkSysTvName,
mkFCallName, mkIPName,
+ mkTickBoxOpName,
mkExternalName, mkWiredInName,
nameUnique, setNameUnique,
mkFCallName uniq str = Name { n_uniq = getKey# uniq, n_sort = Internal,
n_occ = mkVarOcc str, n_loc = noSrcLoc }
+mkTickBoxOpName :: Unique -> String -> Name
+mkTickBoxOpName uniq str
+ = Name { n_uniq = getKey# uniq, n_sort = Internal,
+ n_occ = mkVarOcc str, n_loc = noSrcLoc }
+
mkIPName :: Unique -> OccName -> Name
mkIPName uniq occ
= Name { n_uniq = getKey# uniq,
import VarSet
import VarEnv
import Id
+import IdInfo
import DataCon
import PrimOp
import BasicTypes
import Util
import Outputable
import TysWiredIn
+import MkId
+import TysPrim
\end{code}
-- ---------------------------------------------------------------------------
exprIsTrivial (Lit lit) = True
exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
exprIsTrivial (Note (SCC _) e) = False
-exprIsTrivial (Note (TickBox {}) e) = False
-exprIsTrivial (Note (BinaryTickBox {}) e) = False
exprIsTrivial (Note _ e) = exprIsTrivial e
exprIsTrivial (Cast e co) = exprIsTrivial e
exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
deLamFloat expr1 `thenUs` \ (floats, expr2) ->
returnUs (floats, Note n expr2)
-corePrepExprFloat env (Note note@(TickBox {}) expr)
+corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
+ | Just (TickBox {}) <- isTickBoxOp_maybe id
= corePrepAnExpr env expr `thenUs` \ expr1 ->
deLamFloat expr1 `thenUs` \ (floats, expr2) ->
- return (floats, Note note expr2)
+ return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)])
-corePrepExprFloat env (Note note@(BinaryTickBox m t e) expr)
+-- Translate Binary tickBox into standard tickBox
+corePrepExprFloat env (App (Var id) expr)
+ | Just (BinaryTickBox m t e) <- isTickBoxOp_maybe id
= corePrepAnExpr env expr `thenUs` \ expr1 ->
deLamFloat expr1 `thenUs` \ (floats, expr2) ->
- getUniqueUs `thenUs` \ u ->
- let bndr = mkSysLocal FSLIT("t") u boolTy in
+ getUniqueUs `thenUs` \ u1 ->
+ getUniqueUs `thenUs` \ u2 ->
+ getUniqueUs `thenUs` \ u3 ->
+ getUniqueUs `thenUs` \ u4 ->
+ getUniqueUs `thenUs` \ u5 ->
+ let bndr1 = mkSysLocal FSLIT("t1") u1 boolTy in
+ let bndr2 = mkSysLocal FSLIT("t2") u2 realWorldStatePrimTy in
+ let bndr3 = mkSysLocal FSLIT("t3") u3 realWorldStatePrimTy in
+ let tick_e = mkTickBoxOpId u4 m e in
+ let tick_t = mkTickBoxOpId u5 m t in
return (floats, Case expr2
- bndr
+ bndr1
boolTy
- [ (DataAlt falseDataCon, [], Note (TickBox m e) (Var falseDataConId))
- , (DataAlt trueDataCon, [], Note (TickBox m t) (Var trueDataConId))
+ [ (DataAlt falseDataCon, [],
+ Case (Var tick_e) bndr2 boolTy [(DEFAULT,[],Var falseDataConId)])
+ , (DataAlt trueDataCon, [],
+ Case (Var tick_t) bndr3 boolTy [(DEFAULT,[],Var trueDataConId)])
])
corePrepExprFloat env (Note other_note expr)
where
(bndrs,body) = collectBinders expr
-corePrepExprFloat env (Case (Note note@(TickBox m n) expr) bndr ty alts)
- = corePrepExprFloat env (Note note (Case expr bndr ty alts))
-
-corePrepExprFloat env (Case (Note note@(BinaryTickBox m t e) expr) bndr ty alts)
- = do { ASSERT(exprType expr `coreEqType` boolTy)
- corePrepExprFloat env $
- Case expr bndr ty
- [ (DataAlt falseDataCon, [], Note (TickBox m e) falseBranch)
- , (DataAlt trueDataCon, [], Note (TickBox m t) trueBranch)
+-- This is an (important) optimization.
+-- case <btick,A,B> e of { T -> e1 ; F -> e2 }
+-- ==> case e of { T -> <tick,A> e1 ; F -> <tick,B> e2 }
+-- This could move into the simplifier.
+
+corePrepExprFloat env (Case (App (Var id) expr) bndr ty alts)
+ | Just (BinaryTickBox m t e) <- isTickBoxOp_maybe id
+ = getUniqueUs `thenUs` \ u1 ->
+ getUniqueUs `thenUs` \ u2 ->
+ getUniqueUs `thenUs` \ u3 ->
+ getUniqueUs `thenUs` \ u4 ->
+ getUniqueUs `thenUs` \ u5 ->
+ let bndr1 = mkSysLocal FSLIT("t1") u1 boolTy in
+ let bndr2 = mkSysLocal FSLIT("t2") u2 realWorldStatePrimTy in
+ let bndr3 = mkSysLocal FSLIT("t3") u3 realWorldStatePrimTy in
+ let tick_e = mkTickBoxOpId u4 m e in
+ let tick_t = mkTickBoxOpId u5 m t in
+ ASSERT (exprType expr `coreEqType` boolTy)
+ corePrepExprFloat env $
+ Case expr
+ bndr1
+ ty
+ [ (DataAlt falseDataCon, [],
+ Case (Var tick_e) bndr2 ty [(DEFAULT,[],falseBranch)])
+ , (DataAlt trueDataCon, [],
+ Case (Var tick_t) bndr3 ty [(DEFAULT,[],trueBranch)])
]
- }
+
where
(_,_,trueBranch) = findAlt (DataAlt trueDataCon) alts
(_,_,falseBranch) = findAlt (DataAlt falseDataCon) alts
import BasicTypes
import FastString
import Outputable
-import Module
infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
| CoreNote String -- A generic core annotation, propagated but not used by GHC
- | TickBox Module !Int -- ^Tick box for Hpc-style coverage
- | BinaryTickBox Module !Int !Int
- -- ^Binary tick box, with a tick for result = True, result = False
-
-
-- NOTE: we also treat expressions wrapped in InlineMe as
-- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
-- What this means is that we obediently inline even things that don't
seqExprs (e:es) = seqExpr e `seq` seqExprs es
seqNote (CoreNote s) = s `seq` ()
-seqNote (TickBox m n) = m `seq` () -- no need for seq on n, because n is strict
-seqNote (BinaryTickBox m t f)
- = m `seq` () -- likewise on t and f.
seqNote other = ()
seqBndr b = b `seq` ()
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation (Lit _) = True
exprOkForSpeculation (Type _) = True
+ -- Tick boxes are *not* suitable for speculation
exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
+ && not (isTickBoxOp v)
exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
exprOkForSpeculation (Cast e co) = exprOkForSpeculation e
exprOkForSpeculation other_expr
exprIsHNF (Type ty) = True -- Types are honorary Values;
-- we don't mind copying them
exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
-exprIsHNF (Note (TickBox {}) _)
- = False
-exprIsHNF (Note (BinaryTickBox {}) _)
- = False
exprIsHNF (Note _ e) = exprIsHNF e
exprIsHNF (Cast e co) = exprIsHNF e
exprIsHNF (App e (Type _)) = exprIsHNF e
Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
}}
+{-
-- We do not want to tell the world that we have a
-- Cons, to *stop* Case of Known Cons, which removes
-- the TickBox.
= Nothing
exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
= Nothing
+-}
exprIsConApp_maybe (Note _ expr)
= exprIsConApp_maybe expr
go (Var v) = idArity v
go (Lam x e) | isId x = go e + 1
| otherwise = go e
- go (Note (TickBox {}) _) = 0
- go (Note (BinaryTickBox {}) _)
- = 0
go (Note n e) = go e
go (Cast e _) = go e
go (App e (Type t)) = go e
noteSize (SCC cc) = cc `seq` 1
noteSize InlineMe = 1
noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
-noteSize (TickBox m n) = m `seq` n `seq` 1
-noteSize (BinaryTickBox m t e) = m `seq` t `seq` e `seq` 1
-
+
varSize :: Var -> Int
varSize b | isTyVar b = 1
| otherwise = seqType (idType b) `seq`
is_static False (Lam b e) = isRuntimeVar b || is_static False e
is_static in_arg (Note (SCC _) e) = False
- is_static in_arg (Note (TickBox {}) e) = False
- is_static in_arg (Note (BinaryTickBox {}) e) = False
is_static in_arg (Note _ e) = is_static in_arg e
is_static in_arg (Cast e co) = is_static in_arg e
ppr_expr add_par (Note InlineMe expr)
= add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr
-ppr_expr add_par (Note (TickBox mod n) expr)
- = add_par $
- sep [sep [ptext SLIT("__tick_box"),
- pprModule mod,
- text (show n)],
- pprParendExpr expr]
-
-ppr_expr add_par (Note (BinaryTickBox mod t e) expr)
- = add_par $
- sep [sep [ptext SLIT("__binary_tick_box"),
- pprModule mod,
- text (show t),
- text (show e)],
- pprParendExpr expr]
-
ppr_expr add_par (Note (CoreNote s) expr)
= add_par $
sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
\begin{code}
addCoverageTicksToBinds dflags mod mod_loc binds = do
+ { let orig_file =
+ case ml_hs_file mod_loc of
+ Just file -> file
+ Nothing -> error "can not find the original file during hpc trans"
+
+ ; if "boot" `isSuffixOf` orig_file then return (binds, 0)
+ else addCoverageTicksToBinds2 dflags mod orig_file binds
+ }
+
+addCoverageTicksToBinds2 dflags mod orig_file binds = do
let main_mod = mainModIs dflags
main_is = case mainFunIs dflags of
Nothing -> "main"
Just main -> main
+ modTime <- getModificationTime' orig_file
+
let mod_name = moduleNameString (moduleName mod)
let (binds1,st)
-- write the mix entries for this module
let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
- let orig_file = case ml_hs_file mod_loc of
- Just file -> file
- Nothing -> error "can not find the original file during hpc trans"
-
- modTime <- getModificationTime' orig_file
-
createDirectoryIfMissing True hpc_dir
mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop $ reverse $ mixEntries st)
import ListSetOps
import FastString
import Data.Char
+import DynFlags
#ifdef DEBUG
import Util
mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
mkTickBox ix e = do
+ dflags <- getDOptsDs
+ uq <- newUnique
mod <- getModuleDs
- return $ Note (TickBox mod ix) e
+ let tick = mkTickBoxOpId uq mod ix
+ uq2 <- newUnique
+ let occName = mkVarOcc "tick"
+ let name = mkInternalName uq2 occName noSrcLoc -- use mkSysLocal?
+ let var = Id.mkLocalId name realWorldStatePrimTy
+ return $ Case (Var tick)
+ var
+ ty
+ [(DEFAULT,[],e)]
+ where
+ ty = exprType e
mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox ixT ixF e = do
mod <- getModuleDs
- return $ Note (BinaryTickBox mod ixT ixF) e
+ dflags <- getDOptsDs
+ uq <- newUnique
+ mod <- getModuleDs
+ let tick = mkBinaryTickBoxOpId uq mod ixT ixF
+ return $ App (Var tick) e
\end{code}
\ No newline at end of file
put_ bh (IfaceCoreNote s) = do
putByte bh 4
put_ bh s
- put_ bh (IfaceTickBox m n) = do
- putByte bh 5
- put_ bh m
- put_ bh n
- put_ bh (IfaceBinaryTickBox m t e) = do
- putByte bh 6
- put_ bh m
- put_ bh t
- put_ bh e
get bh = do
h <- getByte bh
case h of
3 -> do return IfaceInlineMe
4 -> do ac <- get bh
return (IfaceCoreNote ac)
- 5 -> do m <- get bh
- n <- get bh
- return (IfaceTickBox m n)
- 6 -> do m <- get bh
- t <- get bh
- e <- get bh
- return (IfaceBinaryTickBox m t e)
-------------------------------------------------------------------------
-- IfaceDecl and friends
data IfaceNote = IfaceSCC CostCentre
| IfaceInlineMe
| IfaceCoreNote String
- | IfaceTickBox Module Int
- | IfaceBinaryTickBox Module Int Int
type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
-- Note: FastString, not IfaceBndr (and same with the case binder)
ppr (IfaceSCC cc) = pprCostCentreCore cc
ppr IfaceInlineMe = ptext SLIT("__inline_me")
ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
- ppr (IfaceTickBox m n) = ptext SLIT("__tick_box") <+> pprModule m <+> text (show n)
- ppr (IfaceBinaryTickBox m t e)
- = ptext SLIT("__binary_tick_box")
- <+> pprModule m
- <+> text (show t)
- <+> text (show e)
instance Outputable IfaceConAlt where
eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
-eq_ifaceNote env (IfaceTickBox m1 n1) (IfaceTickBox m2 n2) = bool (m1==m2 && n1==n2)
-eq_ifaceNote env (IfaceBinaryTickBox m1 t1 e1) (IfaceBinaryTickBox m2 t2 e2) = bool (m1==m2 && t1==t2 && e1 == e2)
eq_ifaceNote env _ _ = NotEqual
\end{code}
toIfaceNote (SCC cc) = IfaceSCC cc
toIfaceNote InlineMe = IfaceInlineMe
toIfaceNote (CoreNote s) = IfaceCoreNote s
-toIfaceNote (TickBox m n) = IfaceTickBox m n
-toIfaceNote (BinaryTickBox m t e)
- = IfaceBinaryTickBox m t e
---------------------
toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceIdBndr b) (toIfaceExpr r)
IfaceInlineMe -> returnM (Note InlineMe expr')
IfaceSCC cc -> returnM (Note (SCC cc) expr')
IfaceCoreNote n -> returnM (Note (CoreNote n) expr')
- IfaceTickBox m n -> returnM (Note (TickBox m n) expr')
- IfaceBinaryTickBox m t e -> returnM (Note (BinaryTickBox m t e) expr')
-------------------------
tcIfaceAlt _ (IfaceDefault, names, rhs)
| Opt_PrintBindResult
| Opt_Haddock
| Opt_Hpc
- | Opt_Hpc_Trace
+ | Opt_Hpc_Tracer
-- keeping stuff
| Opt_KeepHiDiffs
( "print-bind-result", Opt_PrintBindResult ),
( "force-recomp", Opt_ForceRecomp ),
( "hpc", Opt_Hpc ),
- ( "hpc-tracer", Opt_Hpc )
+ ( "hpc-tracer", Opt_Hpc_Tracer )
]
import Var ( Id, Var )
import Id ( idType, idInfo, idName, idCoreRules, isGlobalId,
isExportedId, mkVanillaGlobal, isLocalId, isNaughtyRecordSelector,
- idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo
+ idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo,
+ isTickBoxOp
)
import IdInfo {- loads of stuff -}
import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId )
\begin{code}
hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
hasCafRefs this_pkg p arity expr
- | is_caf || mentions_cafs || is_tick
+ | is_caf || mentions_cafs
= MayHaveCafRefs
| otherwise = NoCafRefs
where
mentions_cafs = isFastTrue (cafRefs p expr)
is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
- is_tick = case expr of
- Note (TickBox {}) _ -> True
- Note (BinaryTickBox {}) _ -> True
- _ -> False
-
+
-- NB. we pass in the arity of the expression, which is expected
-- to be calculated by exprArity. This is because exprArity
-- knows how much eta expansion is going to be done by
= -- Ditto... don't float anything into an INLINE expression
mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
-fiExpr to_drop (_, AnnNote note@(TickBox {}) expr)
- = -- Wimp out for now
- mkCoLets' to_drop (Note note (fiExpr [] expr))
-fiExpr to_drop (_, AnnNote note@(BinaryTickBox {}) expr)
- = -- Wimp out for now
- mkCoLets' to_drop (Note note (fiExpr [] expr))
-
fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
= Note note (fiExpr to_drop expr)
\end{code}
= simplExprF env e cont
simplNote env (CoreNote s) e cont
- = do { e' <- simplExpr env e
- ; rebuild env (Note (CoreNote s) e') cont }
-
-simplNote env note@(TickBox {}) e cont
- = do { e' <- simplExpr env e
- ; rebuild env (Note note e') cont }
-
-simplNote env note@(BinaryTickBox {}) e cont
- = do { e' <- simplExpr env e
- ; rebuild env (Note note e') cont }
+ = simplExpr env e `thenSmpl` \ e' ->
+ rebuild env (Note (CoreNote s) e') cont
\end{code}
= 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
-> [CoreArg] -- Arguments
-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
+
coreToStgApp maybe_thunk_body f args
= coreToStgArgs args `thenLne` \ (args', args_fvs) ->
lookupVarLne f `thenLne` \ how_bound ->
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
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 (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)