mkRtsDataLabel,
mkRtsGcPtrLabel,
- mkRtsInfoLabelFS,
- mkRtsEntryLabelFS,
- mkRtsRetInfoLabelFS,
- mkRtsRetLabelFS,
- mkRtsCodeLabelFS,
- mkRtsDataLabelFS,
-
mkRtsApFastLabel,
mkPrimCallLabel,
| RtsPrimOp PrimOp
- | RtsInfo LitString -- misc rts info tables
- | RtsEntry LitString -- misc rts entry points
- | RtsRetInfo LitString -- misc rts ret info tables
- | RtsRet LitString -- misc rts return points
- | RtsData LitString -- misc rts data bits
- | RtsGcPtr LitString -- GcPtrs eg CHARLIKE_closure
- | RtsCode LitString -- misc rts code
-
- | RtsInfoFS FastString -- misc rts info tables
- | RtsEntryFS FastString -- misc rts entry points
- | RtsRetInfoFS FastString -- misc rts ret info tables
- | RtsRetFS FastString -- misc rts return points
- | RtsDataFS FastString -- misc rts data bits, eg CHARLIKE_closure
- | RtsCodeFS FastString -- misc rts code
+ | RtsInfo FastString -- misc rts info tables
+ | RtsEntry FastString -- misc rts entry points
+ | RtsRetInfo FastString -- misc rts ret info tables
+ | RtsRet FastString -- misc rts return points
+ | RtsData FastString -- misc rts data bits, eg CHARLIKE_closure
+ | RtsCode FastString -- misc rts code
+ | RtsGcPtr FastString -- GcPtrs eg CHARLIKE_closure
- | RtsApFast LitString -- _fast versions of generic apply
+ | RtsApFast FastString -- _fast versions of generic apply
| RtsSlowTickyCtr String
-- Some fixed runtime system labels
-mkSplitMarkerLabel = RtsLabel (RtsCode (sLit "__stg_split_marker"))
-mkDirty_MUT_VAR_Label = RtsLabel (RtsCode (sLit "dirty_MUT_VAR"))
-mkUpdInfoLabel = RtsLabel (RtsInfo (sLit "stg_upd_frame"))
-mkIndStaticInfoLabel = RtsLabel (RtsInfo (sLit "stg_IND_STATIC"))
-mkMainCapabilityLabel = RtsLabel (RtsData (sLit "MainCapability"))
-mkMAP_FROZEN_infoLabel = RtsLabel (RtsInfo (sLit "stg_MUT_ARR_PTRS_FROZEN0"))
-mkMAP_DIRTY_infoLabel = RtsLabel (RtsInfo (sLit "stg_MUT_ARR_PTRS_DIRTY"))
-mkEMPTY_MVAR_infoLabel = RtsLabel (RtsInfo (sLit "stg_EMPTY_MVAR"))
-
-mkTopTickyCtrLabel = RtsLabel (RtsData (sLit "top_ct"))
-mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsInfo (sLit "stg_CAF_BLACKHOLE"))
+mkSplitMarkerLabel = RtsLabel (RtsCode (fsLit "__stg_split_marker"))
+mkDirty_MUT_VAR_Label = RtsLabel (RtsCode (fsLit "dirty_MUT_VAR"))
+mkUpdInfoLabel = RtsLabel (RtsInfo (fsLit "stg_upd_frame"))
+mkIndStaticInfoLabel = RtsLabel (RtsInfo (fsLit "stg_IND_STATIC"))
+mkMainCapabilityLabel = RtsLabel (RtsData (fsLit "MainCapability"))
+mkMAP_FROZEN_infoLabel = RtsLabel (RtsInfo (fsLit "stg_MUT_ARR_PTRS_FROZEN0"))
+mkMAP_DIRTY_infoLabel = RtsLabel (RtsInfo (fsLit "stg_MUT_ARR_PTRS_DIRTY"))
+mkEMPTY_MVAR_infoLabel = RtsLabel (RtsInfo (fsLit "stg_EMPTY_MVAR"))
+
+mkTopTickyCtrLabel = RtsLabel (RtsData (fsLit "top_ct"))
+mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsInfo (fsLit "stg_CAF_BLACKHOLE"))
mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
moduleRegdLabel = ModuleRegdLabel
mkRtsDataLabel str = RtsLabel (RtsData str)
mkRtsGcPtrLabel str = RtsLabel (RtsGcPtr str)
-mkRtsInfoLabelFS str = RtsLabel (RtsInfoFS str)
-mkRtsEntryLabelFS str = RtsLabel (RtsEntryFS str)
-mkRtsRetInfoLabelFS str = RtsLabel (RtsRetInfoFS str)
-mkRtsRetLabelFS str = RtsLabel (RtsRetFS str)
-mkRtsCodeLabelFS str = RtsLabel (RtsCodeFS str)
-mkRtsDataLabelFS str = RtsLabel (RtsDataFS str)
-
mkRtsApFastLabel str = RtsLabel (RtsApFast str)
mkRtsSlowTickyCtrLabel :: String -> CLabel
-- Converting between info labels and entry/ret labels.
infoLblToEntryLbl :: CLabel -> CLabel
-infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry
-infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry
+infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry
+infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry
infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry
-infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
-infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s)
-infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s)
-infoLblToEntryLbl (RtsLabel (RtsInfoFS s)) = RtsLabel (RtsEntryFS s)
-infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s)
+infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
+infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s)
+infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s)
infoLblToEntryLbl _ = panic "CLabel.infoLblToEntryLbl"
entryLblToInfoLbl :: CLabel -> CLabel
-entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable
-entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable
-entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable
-entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
-entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s)
-entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s)
-entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s)
-entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s)
+entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable
+entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable
+entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable
+entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
+entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s)
+entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s)
entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure
labelType (RtsLabel (RtsEntry _)) = CodeLabel
labelType (RtsLabel (RtsRetInfo _)) = DataLabel
labelType (RtsLabel (RtsRet _)) = CodeLabel
-labelType (RtsLabel (RtsDataFS _)) = DataLabel
-labelType (RtsLabel (RtsCodeFS _)) = CodeLabel
-labelType (RtsLabel (RtsInfoFS _)) = DataLabel
-labelType (RtsLabel (RtsEntryFS _)) = CodeLabel
-labelType (RtsLabel (RtsRetInfoFS _)) = DataLabel
-labelType (RtsLabel (RtsRetFS _)) = CodeLabel
-labelType (RtsLabel (RtsApFast _)) = CodeLabel
-labelType (CaseLabel _ CaseReturnInfo) = DataLabel
-labelType (CaseLabel _ _) = CodeLabel
-labelType (ModuleInitLabel _ _) = CodeLabel
-labelType (PlainModuleInitLabel _) = CodeLabel
-labelType (ModuleInitTableLabel _) = DataLabel
-labelType (LargeSRTLabel _) = DataLabel
-labelType (LargeBitmapLabel _) = DataLabel
-labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
-labelType (IdLabel _ _ info) = idInfoLabelType info
-labelType _ = DataLabel
+labelType (RtsLabel (RtsApFast _)) = CodeLabel
+labelType (CaseLabel _ CaseReturnInfo) = DataLabel
+labelType (CaseLabel _ _) = CodeLabel
+labelType (ModuleInitLabel _ _) = CodeLabel
+labelType (PlainModuleInitLabel _) = CodeLabel
+labelType (ModuleInitTableLabel _) = DataLabel
+labelType (LargeSRTLabel _) = DataLabel
+labelType (LargeBitmapLabel _) = DataLabel
+labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
+labelType (IdLabel _ _ info) = idInfoLabelType info
+labelType _ = DataLabel
idInfoLabelType info =
case info of
-- with a letter so the label will be legal assmbly code.
-pprCLbl (RtsLabel (RtsCode str)) = ptext str
-pprCLbl (RtsLabel (RtsData str)) = ptext str
-pprCLbl (RtsLabel (RtsGcPtr str)) = ptext str
-pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str
-pprCLbl (RtsLabel (RtsDataFS str)) = ftext str
+pprCLbl (RtsLabel (RtsCode str)) = ftext str
+pprCLbl (RtsLabel (RtsData str)) = ftext str
+pprCLbl (RtsLabel (RtsGcPtr str)) = ftext str
-pprCLbl (RtsLabel (RtsApFast str)) = ptext str <> ptext (sLit "_fast")
+pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> ptext (sLit "_fast")
pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
= hcat [ptext (sLit "stg_sel_"), text (show offset),
]
pprCLbl (RtsLabel (RtsInfo fs))
- = ptext fs <> ptext (sLit "_info")
-
-pprCLbl (RtsLabel (RtsEntry fs))
- = ptext fs <> ptext (sLit "_entry")
-
-pprCLbl (RtsLabel (RtsRetInfo fs))
- = ptext fs <> ptext (sLit "_info")
-
-pprCLbl (RtsLabel (RtsRet fs))
- = ptext fs <> ptext (sLit "_ret")
-
-pprCLbl (RtsLabel (RtsInfoFS fs))
= ftext fs <> ptext (sLit "_info")
-pprCLbl (RtsLabel (RtsEntryFS fs))
+pprCLbl (RtsLabel (RtsEntry fs))
= ftext fs <> ptext (sLit "_entry")
-pprCLbl (RtsLabel (RtsRetInfoFS fs))
+pprCLbl (RtsLabel (RtsRetInfo fs))
= ftext fs <> ptext (sLit "_info")
-pprCLbl (RtsLabel (RtsRetFS fs))
+pprCLbl (RtsLabel (RtsRet fs))
= ftext fs <> ptext (sLit "_ret")
pprCLbl (RtsLabel (RtsPrimOp primop))
new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
let (caller_save, caller_load) = callerSaveVolatileRegs
load_tso <- newTemp gcWord -- TODO FIXME NOW
- let suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread")))
- resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread")))
+ let suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "suspendThread")))
+ resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "resumeThread")))
suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*>
saveThreadState <*>
caller_save <*>
-- Save/restore the thread state in the TSO
suspendThread, resumeThread :: CmmExpr
-suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread")))
-resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread")))
+suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "suspendThread")))
+resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "resumeThread")))
-- This stuff can't be done in suspendThread/resumeThread, because it
-- refers to global registers which aren't available in the C world.
-- Strings aren't used much in the RTS HC code, so it doesn't seem
-- worth allowing inline strings. C-- doesn't allow them anyway.
static :: { ExtFCode [CmmStatic] }
- : NAME ':' { return [CmmDataLabel (mkRtsDataLabelFS $1)] }
+ : NAME ':' { return [CmmDataLabel (mkRtsDataLabel $1)] }
| type expr ';' { do e <- $2;
return [CmmStaticLit (getLit e)] }
| type ';' { return [CmmUninitialised
$6;
return (formals, gc_block, frame) }
blks <- code (cgStmtsToBlocks stmts)
- code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) }
+ code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkRtsCodeLabel $1) formals blks) }
info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type
{ do prof <- profilingInfo $11 $13
- return (mkRtsEntryLabelFS $3,
+ return (mkRtsEntryLabel $3,
CmmInfoTable False prof (fromIntegral $9)
(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
[]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type
{ do prof <- profilingInfo $11 $13
- return (mkRtsEntryLabelFS $3,
+ return (mkRtsEntryLabel $3,
CmmInfoTable False prof (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT
0 -- Arity zero
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type, arity
{ do prof <- profilingInfo $11 $13
- return (mkRtsEntryLabelFS $3,
+ return (mkRtsEntryLabel $3,
CmmInfoTable False prof (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17)
(ArgSpec (fromIntegral $15))
-- If profiling is on, this string gets duplicated,
-- but that's the way the old code did it we can fix it some other time.
desc_lit <- code $ mkStringCLit $13
- return (mkRtsEntryLabelFS $3,
+ return (mkRtsEntryLabel $3,
CmmInfoTable False prof (fromIntegral $11)
(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
[]) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type
{ do prof <- profilingInfo $9 $11
- return (mkRtsEntryLabelFS $3,
+ return (mkRtsEntryLabel $3,
CmmInfoTable False prof (fromIntegral $7)
(ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
[]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
-- closure type (no live regs)
- { do let infoLabel = mkRtsInfoLabelFS $3
- return (mkRtsRetLabelFS $3,
+ { do let infoLabel = mkRtsInfoLabel $3
+ return (mkRtsRetLabel $3,
CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
(ContInfo [] NoC_SRT),
[]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
-- closure type, live regs
{ do live <- sequence (map (liftM Just) $7)
- return (mkRtsRetLabelFS $3,
+ return (mkRtsRetLabel $3,
CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
(ContInfo live NoC_SRT),
live) }
return $
case lookupUFM env name of
Just (Var e) -> e
- _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
+ _other -> CmmLit (CmmLabel (mkRtsCodeLabel name))
-- Lifting FCode computations into the ExtFCode monad:
code :: FCode a -> ExtFCode a
staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
staticClosure cl_label info payload
- = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
- where lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] []
+ = code $ emitDataLits (mkRtsDataLabel cl_label) lits
+ where lits = mkStaticClosure (mkRtsInfoLabel info) dontCareCCS payload [] [] []
foreignCall
:: String
-- don't forget the zero case
constructSlowCall []
- = (mkRtsApFastLabel (sLit "stg_ap_0"), [], [])
+ = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], [])
constructSlowCall amodes
= (stg_ap_pat, these, rest)
stg_ap_pat = mkRtsRetInfoLabel arg_pat
matchSlowPattern :: [(CgRep,CmmExpr)]
- -> (LitString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
+ -> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
matchSlowPattern amodes = (arg_pat, these, rest)
where (arg_pat, n) = slowCallPattern (map fst amodes)
(these, rest) = splitAt n amodes
-- These cases were found to cover about 99% of all slow calls:
-slowCallPattern :: [CgRep] -> (LitString, Int)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_pppppp", 6)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_ppppp", 5)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_pppp", 4)
-slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (sLit "stg_ap_pppv", 4)
-slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_ppp", 3)
-slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (sLit "stg_ap_ppv", 3)
-slowCallPattern (PtrArg: PtrArg: _) = (sLit "stg_ap_pp", 2)
-slowCallPattern (PtrArg: VoidArg: _) = (sLit "stg_ap_pv", 2)
-slowCallPattern (PtrArg: _) = (sLit "stg_ap_p", 1)
-slowCallPattern (VoidArg: _) = (sLit "stg_ap_v", 1)
-slowCallPattern (NonPtrArg: _) = (sLit "stg_ap_n", 1)
-slowCallPattern (FloatArg: _) = (sLit "stg_ap_f", 1)
-slowCallPattern (DoubleArg: _) = (sLit "stg_ap_d", 1)
-slowCallPattern (LongArg: _) = (sLit "stg_ap_l", 1)
-slowCallPattern _ = panic "CgStackery.slowCallPattern"
+slowCallPattern :: [CgRep] -> (FastString, Int)
+slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppppp", 6)
+slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppppp", 5)
+slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppp", 4)
+slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_pppv", 4)
+slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppp", 3)
+slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_ppv", 3)
+slowCallPattern (PtrArg: PtrArg: _) = (fsLit "stg_ap_pp", 2)
+slowCallPattern (PtrArg: VoidArg: _) = (fsLit "stg_ap_pv", 2)
+slowCallPattern (PtrArg: _) = (fsLit "stg_ap_p", 1)
+slowCallPattern (VoidArg: _) = (fsLit "stg_ap_v", 1)
+slowCallPattern (NonPtrArg: _) = (fsLit "stg_ap_n", 1)
+slowCallPattern (FloatArg: _) = (fsLit "stg_ap_f", 1)
+slowCallPattern (DoubleArg: _) = (fsLit "stg_ap_d", 1)
+slowCallPattern (LongArg: _) = (fsLit "stg_ap_l", 1)
+slowCallPattern _ = panic "CgStackery.slowCallPattern"
-------------------------------------------------------------------------
--
-- so that the garbage collector can find them
-- This must be done *before* the info table pointer is overwritten,
-- because the old info table ptr is needed for reversion
- ; emitRtsCallWithVols (sLit "newCAF") [CmmHinted (CmmReg nodeReg) AddrHint] [node] False
+ ; emitRtsCallWithVols (fsLit "newCAF") [CmmHinted (CmmReg nodeReg) AddrHint] [node] False
-- node is live, so save it.
-- Overwrite the closure with a (static) indirection
, (_, CmmLit (CmmInt val _)) <- arg_amode
, let val_int = (fromIntegral val) :: Int
, val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE
- = do { let intlike_lbl = mkRtsGcPtrLabel (sLit "stg_INTLIKE_closure")
+ = do { let intlike_lbl = mkRtsGcPtrLabel (fsLit "stg_INTLIKE_closure")
offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
-- INTLIKE closures consist of a header and one word payload
intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW)
, (_, CmmLit (CmmInt val _)) <- arg_amode
, let val_int = (fromIntegral val) :: Int
, val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE
- = do { let charlike_lbl = mkRtsGcPtrLabel (sLit "stg_CHARLIKE_closure")
+ = do { let charlike_lbl = mkRtsGcPtrLabel (fsLit "stg_CHARLIKE_closure")
offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
-- CHARLIKE closures consist of a header and one word payload
charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW)
emitLoadThreadState
suspendThread, resumeThread :: CmmExpr
-suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread")))
-resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread")))
+suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "suspendThread")))
+resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "resumeThread")))
-- we might need to load arguments into temporaries before
; setRealHp hpHw
; code }
where
- rts_label PolyAlt = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_unpt_r1")))
+ rts_label PolyAlt = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "stg_gc_unpt_r1")))
-- Do *not* enter R1 after a heap check in
-- a polymorphic case. It might be a function
-- and the entry code for a function (currently)
rts_label (PrimAlt tc)
= CmmLit $ CmmLabel $
case primRepToCgRep (tyConPrimRep tc) of
- VoidArg -> mkRtsCodeLabel (sLit "stg_gc_noregs")
- FloatArg -> mkRtsCodeLabel (sLit "stg_gc_f1")
- DoubleArg -> mkRtsCodeLabel (sLit "stg_gc_d1")
- LongArg -> mkRtsCodeLabel (sLit "stg_gc_l1")
+ VoidArg -> mkRtsCodeLabel (fsLit "stg_gc_noregs")
+ FloatArg -> mkRtsCodeLabel (fsLit "stg_gc_f1")
+ DoubleArg -> mkRtsCodeLabel (fsLit "stg_gc_d1")
+ LongArg -> mkRtsCodeLabel (fsLit "stg_gc_l1")
-- R1 is boxed but unlifted:
- PtrArg -> mkRtsCodeLabel (sLit "stg_gc_unpt_r1")
+ PtrArg -> mkRtsCodeLabel (fsLit "stg_gc_unpt_r1")
-- R1 is unboxed:
- NonPtrArg -> mkRtsCodeLabel (sLit "stg_gc_unbx_r1")
+ NonPtrArg -> mkRtsCodeLabel (fsLit "stg_gc_unbx_r1")
rts_label (UbxTupAlt _) = panic "altHeapCheck"
\end{code}
assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho!
(CmmLit (mkWordCLit liveness))
liveness = mkRegLiveness regs ptrs nptrs
- rts_label = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_ut")))
+ rts_label = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "stg_gc_ut")))
\end{code}
= do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1
stg_gc_gen :: CmmExpr
-stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_gen")))
+stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "stg_gc_gen")))
stg_gc_enter1 :: CmmExpr
stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
\end{code}
NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn
where
- newspark = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "newSpark")))
+ newspark = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "newSpark")))
emitPrimOp [res] ReadMutVarOp [mutv] _
= stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord))
-- Address of current CCS variable, for storing into
curCCSAddr :: CmmExpr
-curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCCS")))
+curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCCS")))
mkCCostCentre :: CostCentre -> CmmLit
mkCCostCentre cc = CmmLabel (mkCCLabel cc)
stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
enter_ccs_fun :: CmmExpr -> Code
-enter_ccs_fun stack = emitRtsCall (sLit "EnterFunCCS") [CmmHinted stack AddrHint] False
+enter_ccs_fun stack = emitRtsCall (fsLit "EnterFunCCS") [CmmHinted stack AddrHint] False
-- ToDo: vols
enter_ccs_fsub :: Code
-- entering via a PAP.
enteringPAP :: Integer -> Code
enteringPAP n
- = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel (sLit "entering_PAP"))))
+ = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel (fsLit "entering_PAP"))))
(CmmLit (CmmInt n cIntWidth)))
ifProfiling :: Code -> Code
cC_LIST, cC_ID :: CmmExpr
-cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_LIST")))
-cC_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_ID")))
+cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CC_LIST")))
+cC_ID = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CC_ID")))
cCS_LIST, cCS_ID :: CmmExpr
-cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_LIST")))
-cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_ID")))
+cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCS_LIST")))
+cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCS_ID")))
-- ---------------------------------------------------------------------------
-- Set the current cost centre stack
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
pushCostCentre result ccs cc
= emitRtsCallWithResult result AddrHint
- (sLit "PushCostCentre") [CmmHinted ccs AddrHint,
+ (fsLit "PushCostCentre") [CmmHinted ccs AddrHint,
CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
False
loadEra :: CmmExpr
loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
- [CmmLoad (mkLblExpr (mkRtsDataLabel $ sLit("era"))) cInt]
+ [CmmLoad (mkLblExpr (mkRtsDataLabel $ fsLit("era"))) cInt]
ldvWord :: CmmExpr -> CmmExpr
-- Takes the address of a closure, and returns
-- Ticky stack frames
tickyPushUpdateFrame, tickyUpdateFrameOmitted :: Code
-tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (sLit "UPDF_PUSHED_ctr")
-tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (sLit "UPDF_OMITTED_ctr")
+tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
+tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
-- -----------------------------------------------------------------------------
-- Ticky entries
tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon,
tickyEnterStaticThunk, tickyEnterViaNode :: Code
-tickyEnterDynCon = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_CON_ctr")
-tickyEnterDynThunk = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_THK_ctr")
-tickyEnterStaticCon = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_CON_ctr")
-tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_THK_ctr")
-tickyEnterViaNode = ifTicky $ bumpTickyCounter (sLit "ENT_VIA_NODE_ctr")
+tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
+tickyEnterDynThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr")
+tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
+tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr")
+tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
tickyEnterThunk :: ClosureInfo -> Code
tickyEnterThunk cl_info
tickyBlackHole updatable
= ifTicky (bumpTickyCounter ctr)
where
- ctr | updatable = sLit "UPD_BH_SINGLE_ENTRY_ctr"
- | otherwise = sLit "UPD_BH_UPDATABLE_ctr"
+ ctr | updatable = fsLit "UPD_BH_SINGLE_ENTRY_ctr"
+ | otherwise = fsLit "UPD_BH_UPDATABLE_ctr"
tickyUpdateBhCaf :: ClosureInfo -> Code
tickyUpdateBhCaf cl_info
= ifTicky (bumpTickyCounter ctr)
where
- ctr | closureUpdReqd cl_info = sLit "UPD_CAF_BH_SINGLE_ENTRY_ctr"
- | otherwise = sLit "UPD_CAF_BH_UPDATABLE_ctr"
+ ctr | closureUpdReqd cl_info = fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr"
+ | otherwise = fsLit "UPD_CAF_BH_UPDATABLE_ctr"
tickyEnterFun :: ClosureInfo -> Code
tickyEnterFun cl_info
; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count)
}
where
- ctr | isStaticClosure cl_info = sLit "ENT_STATIC_FUN_DIRECT_ctr"
- | otherwise = sLit "ENT_DYN_FUN_DIRECT_ctr"
+ ctr | isStaticClosure cl_info = fsLit "ENT_STATIC_FUN_DIRECT_ctr"
+ | otherwise = fsLit "ENT_DYN_FUN_DIRECT_ctr"
registerTickyCtr :: CLabel -> Code
-- Register a ticky counter
, CmmStore (CmmLit (cmmLabelOffB ctr_lbl
oFFSET_StgEntCounter_registeredp))
(CmmLit (mkIntCLit 1)) ]
- ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel (sLit "ticky_entry_ctrs"))
+ ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel (fsLit "ticky_entry_ctrs"))
tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
tickyReturnOldCon arity
- = ifTicky $ do { bumpTickyCounter (sLit "RET_OLD_ctr")
- ; bumpHistogram (sLit "RET_OLD_hst") arity }
+ = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
+ ; bumpHistogram (fsLit "RET_OLD_hst") arity }
tickyReturnNewCon arity
- = ifTicky $ do { bumpTickyCounter (sLit "RET_NEW_ctr")
- ; bumpHistogram (sLit "RET_NEW_hst") arity }
+ = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
+ ; bumpHistogram (fsLit "RET_NEW_hst") arity }
tickyUnboxedTupleReturn :: Int -> Code
tickyUnboxedTupleReturn arity
- = ifTicky $ do { bumpTickyCounter (sLit "RET_UNBOXED_TUP_ctr")
- ; bumpHistogram (sLit "RET_UNBOXED_TUP_hst") arity }
+ = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
+ ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity }
tickyVectoredReturn :: Int -> Code
tickyVectoredReturn family_size
- = ifTicky $ do { bumpTickyCounter (sLit "VEC_RETURN_ctr")
- ; bumpHistogram (sLit "RET_VEC_RETURN_hst") family_size }
+ = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr")
+ ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size }
-- -----------------------------------------------------------------------------
-- Ticky calls
-- Ticks at a *call site*:
tickyKnownCallTooFewArgs, tickyKnownCallExact,
tickyKnownCallExtraArgs, tickyUnknownCall :: Code
-tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
-tickyKnownCallExact = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_ctr")
-tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_EXTRA_ARGS_ctr")
-tickyUnknownCall = ifTicky $ bumpTickyCounter (sLit "UNKNOWN_CALL_ctr")
+tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
+tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
+tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
+tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
-- Tick for the call pattern at slow call site (i.e. in addition to
-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
(CmmLit (cmmLabelOffB ticky_ctr
oFFSET_StgEntCounter_allocs)) hp,
-- Bump ALLOC_HEAP_ctr
- addToMemLbl cLongWidth (mkRtsDataLabel $ sLit "ALLOC_HEAP_ctr") 1,
+ addToMemLbl cLongWidth (mkRtsDataLabel $ fsLit "ALLOC_HEAP_ctr") 1,
-- Bump ALLOC_HEAP_tot
- addToMemLbl cLongWidth (mkRtsDataLabel $ sLit "ALLOC_HEAP_tot") hp] }
+ addToMemLbl cLongWidth (mkRtsDataLabel $ fsLit "ALLOC_HEAP_tot") hp] }
-- -----------------------------------------------------------------------------
-- Ticky utils
addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
-- All the ticky-ticky counters are declared "unsigned long" in C
-bumpTickyCounter :: LitString -> Code
+bumpTickyCounter :: FastString -> Code
bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0)
bumpTickyCounter' :: CmmLit -> Code
-- krc: note that we're incrementing the _entry_count_ field of the ticky counter
bumpTickyCounter' lhs = stmtC (addToMemLong (CmmLit lhs) 1)
-bumpHistogram :: LitString -> Int -> Code
+bumpHistogram :: FastString -> Int -> Code
bumpHistogram _lbl _n
-- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLong))
= return () -- TEMP SPJ Apr 07
; labelC join_id
}
-emitRtsCall :: LitString -> [CmmHinted CmmExpr] -> Bool -> Code
+emitRtsCall :: FastString -> [CmmHinted CmmExpr] -> Bool -> Code
emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
-- The 'Nothing' says "save all global registers"
-emitRtsCallWithVols :: LitString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
+emitRtsCallWithVols :: FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
emitRtsCallWithVols fun args vols safe
= emitRtsCall' [] fun args (Just vols) safe
-emitRtsCallWithResult :: LocalReg -> ForeignHint -> LitString
+emitRtsCallWithResult :: LocalReg -> ForeignHint -> FastString
-> [CmmHinted CmmExpr] -> Bool -> Code
emitRtsCallWithResult res hint fun args safe
= emitRtsCall' [CmmHinted res hint] fun args Nothing safe
-- Make a call to an RTS C procedure
emitRtsCall'
:: [CmmHinted LocalReg]
- -> LitString
+ -> FastString
-> [CmmHinted CmmExpr]
-> Maybe [GlobalReg]
-> Bool -- True <=> CmmSafe call
| otherwise =
nopC
where
- bh_lbl | is_single_entry = mkRtsDataLabel (sLit "stg_SE_BLACKHOLE_info")
- | otherwise = mkRtsDataLabel (sLit "stg_BLACKHOLE_info")
+ bh_lbl | is_single_entry = mkRtsDataLabel (fsLit "stg_SE_BLACKHOLE_info")
+ | otherwise = mkRtsDataLabel (fsLit "stg_BLACKHOLE_info")
-- If we wanted to do eager blackholing with slop filling,
-- we'd need to do it at the *end* of a basic block, otherwise
-- so that the garbage collector can find them
-- This must be done *before* the info table pointer is overwritten,
-- because the old info table ptr is needed for reversion
- ; emitRtsCallWithVols (sLit "newCAF") [(CmmReg nodeReg,AddrHint)] [node] False
+ ; emitRtsCallWithVols (fsLit "newCAF") [(CmmReg nodeReg,AddrHint)] [node] False
-- node is live, so save it.
-- Overwrite the closure with a (static) indirection
, StgLitArg (MachInt val) <- arg
, val <= fromIntegral mAX_INTLIKE -- Comparisons at type Integer!
, val >= fromIntegral mIN_INTLIKE -- ...ditto...
- = do { let intlike_lbl = mkRtsGcPtrLabel (sLit "stg_INTLIKE_closure")
+ = do { let intlike_lbl = mkRtsGcPtrLabel (fsLit "stg_INTLIKE_closure")
val_int = fromIntegral val :: Int
offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
-- INTLIKE closures consist of a header and one word payload
, let val_int = ord val :: Int
, val_int <= mAX_CHARLIKE
, val_int >= mIN_CHARLIKE
- = do { let charlike_lbl = mkRtsGcPtrLabel (sLit "stg_CHARLIKE_closure")
+ = do { let charlike_lbl = mkRtsGcPtrLabel (fsLit "stg_CHARLIKE_closure")
offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
-- CHARLIKE closures consist of a header and one word payload
charlike_amode = cmmLabelOffW charlike_lbl offsetW
import TyCon
import CostCentre
import Outputable
-import FastString( LitString, mkFastString, sLit )
+import FastString( mkFastString, FastString, fsLit )
import Constants
arg_exprs updfr_sz
Nothing -> mkCall generic_gc (GC, GC) [] [] updfr_sz
- gc_lbl :: [LocalReg] -> Maybe LitString
+ gc_lbl :: [LocalReg] -> Maybe FastString
{-
gc_lbl [reg]
| isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p"
gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs)
- gc_lbl_ptrs :: [Bool] -> Maybe LitString
+ gc_lbl_ptrs :: [Bool] -> Maybe FastString
-- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
--gc_lbl_ptrs [True,True] = Just (sLit "stg_gc_fun_2p")
--gc_lbl_ptrs [True,True,True] = Just (sLit "stg_gc_fun_3p")
generic_gc :: CmmExpr -- The generic GC procedure; no params, no resuls
-generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_noregs")))
+generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "stg_gc_noregs")))
-- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
-- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun")))
import Util
import Data.List
import Outputable
-import FastString ( mkFastString, LitString, sLit )
+import FastString ( mkFastString, FastString, fsLit )
------------------------------------------------------------------------
-- Call and return sequences
slow_call fun args reps
= do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++
- " with pat " ++ showSDoc (ptext rts_fun))
+ " with pat " ++ showSDoc (ftext rts_fun))
emit (mkAssign nodeReg fun <*> call)
where
(rts_fun, arity) = slowCallPattern reps
-- These cases were found to cover about 99% of all slow calls:
-slowCallPattern :: [LRep] -> (LitString, Arity)
+slowCallPattern :: [LRep] -> (FastString, Arity)
-- Returns the generic apply function and arity
-slowCallPattern (P: P: P: P: P: P: _) = (sLit "stg_ap_pppppp", 6)
-slowCallPattern (P: P: P: P: P: _) = (sLit "stg_ap_ppppp", 5)
-slowCallPattern (P: P: P: P: _) = (sLit "stg_ap_pppp", 4)
-slowCallPattern (P: P: P: V: _) = (sLit "stg_ap_pppv", 4)
-slowCallPattern (P: P: P: _) = (sLit "stg_ap_ppp", 3)
-slowCallPattern (P: P: V: _) = (sLit "stg_ap_ppv", 3)
-slowCallPattern (P: P: _) = (sLit "stg_ap_pp", 2)
-slowCallPattern (P: V: _) = (sLit "stg_ap_pv", 2)
-slowCallPattern (P: _) = (sLit "stg_ap_p", 1)
-slowCallPattern (V: _) = (sLit "stg_ap_v", 1)
-slowCallPattern (N: _) = (sLit "stg_ap_n", 1)
-slowCallPattern (F: _) = (sLit "stg_ap_f", 1)
-slowCallPattern (D: _) = (sLit "stg_ap_d", 1)
-slowCallPattern (L: _) = (sLit "stg_ap_l", 1)
-slowCallPattern [] = (sLit "stg_ap_0", 0)
+slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)
+slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5)
+slowCallPattern (P: P: P: P: _) = (fsLit "stg_ap_pppp", 4)
+slowCallPattern (P: P: P: V: _) = (fsLit "stg_ap_pppv", 4)
+slowCallPattern (P: P: P: _) = (fsLit "stg_ap_ppp", 3)
+slowCallPattern (P: P: V: _) = (fsLit "stg_ap_ppv", 3)
+slowCallPattern (P: P: _) = (fsLit "stg_ap_pp", 2)
+slowCallPattern (P: V: _) = (fsLit "stg_ap_pv", 2)
+slowCallPattern (P: _) = (fsLit "stg_ap_p", 1)
+slowCallPattern (V: _) = (fsLit "stg_ap_v", 1)
+slowCallPattern (N: _) = (fsLit "stg_ap_n", 1)
+slowCallPattern (F: _) = (fsLit "stg_ap_f", 1)
+slowCallPattern (D: _) = (fsLit "stg_ap_d", 1)
+slowCallPattern (L: _) = (fsLit "stg_ap_l", 1)
+slowCallPattern [] = (fsLit "stg_ap_0", 0)
-------------------------------------------------------------------------
-- later, we might want to inline it.
emitCCall
[(res,NoHint)]
- (CmmLit (CmmLabel (mkRtsCodeLabel (sLit "newSpark"))))
+ (CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "newSpark"))))
[(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)]
emitPrimOp [res] ReadMutVarOp [mutv]
-- Address of current CCS variable, for storing into
curCCSAddr :: CmmExpr
-curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCCS")))
+curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCCS")))
mkCCostCentre :: CostCentre -> CmmLit
mkCCostCentre cc = CmmLabel (mkCCLabel cc)
emit $ mkStore curCCSAddr (costCentreFrom closure)
enter_ccs_fun :: CmmExpr -> FCode ()
-enter_ccs_fun stack = emitRtsCall (sLit "EnterFunCCS") [(stack,AddrHint)] False
+enter_ccs_fun stack = emitRtsCall (fsLit "EnterFunCCS") [(stack,AddrHint)] False
-- ToDo: vols
enter_ccs_fsub :: FCode ()
-- entering via a PAP.
enteringPAP :: Integer -> FCode ()
enteringPAP n
- = emit (mkStore (CmmLit (CmmLabel (mkRtsDataLabel (sLit "entering_PAP"))))
+ = emit (mkStore (CmmLit (CmmLabel (mkRtsDataLabel (fsLit "entering_PAP"))))
(CmmLit (CmmInt n cIntWidth)))
ifProfiling :: FCode () -> FCode ()
cC_LIST, cC_ID :: CmmExpr
-cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_LIST")))
-cC_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_ID")))
+cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CC_LIST")))
+cC_ID = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CC_ID")))
cCS_LIST, cCS_ID :: CmmExpr
-cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_LIST")))
-cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_ID")))
+cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCS_LIST")))
+cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCS_ID")))
-- ---------------------------------------------------------------------------
-- Set the current cost centre stack
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre result ccs cc
= emitRtsCallWithResult result AddrHint
- (sLit "PushCostCentre") [(ccs,AddrHint),
+ (fsLit "PushCostCentre") [(ccs,AddrHint),
(CmmLit (mkCCostCentre cc), AddrHint)]
False
loadEra :: CmmExpr
loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
- [CmmLoad (mkLblExpr (mkRtsDataLabel (sLit "era"))) cInt]
+ [CmmLoad (mkLblExpr (mkRtsDataLabel (fsLit "era"))) cInt]
ldvWord :: CmmExpr -> CmmExpr
-- Takes the address of a closure, and returns
-- Ticky stack frames
tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
-tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (sLit "UPDF_PUSHED_ctr")
-tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (sLit "UPDF_OMITTED_ctr")
+tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
+tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
-- -----------------------------------------------------------------------------
-- Ticky entries
tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon,
tickyEnterStaticThunk, tickyEnterViaNode :: FCode ()
-tickyEnterDynCon = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_CON_ctr")
-tickyEnterDynThunk = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_THK_ctr")
-tickyEnterStaticCon = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_CON_ctr")
-tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_THK_ctr")
-tickyEnterViaNode = ifTicky $ bumpTickyCounter (sLit "ENT_VIA_NODE_ctr")
+tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
+tickyEnterDynThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr")
+tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
+tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr")
+tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
tickyEnterThunk :: ClosureInfo -> FCode ()
tickyEnterThunk cl_info
tickyBlackHole updatable
= ifTicky (bumpTickyCounter ctr)
where
- ctr | updatable = (sLit "UPD_BH_SINGLE_ENTRY_ctr")
- | otherwise = (sLit "UPD_BH_UPDATABLE_ctr")
+ ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")
+ | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")
tickyUpdateBhCaf :: ClosureInfo -> FCode ()
tickyUpdateBhCaf cl_info
= ifTicky (bumpTickyCounter ctr)
where
- ctr | closureUpdReqd cl_info = (sLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
- | otherwise = (sLit "UPD_CAF_BH_UPDATABLE_ctr")
+ ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
+ | otherwise = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")
tickyEnterFun :: ClosureInfo -> FCode ()
tickyEnterFun cl_info
; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count)
}
where
- ctr | isStaticClosure cl_info = (sLit "ENT_STATIC_FUN_DIRECT_ctr")
- | otherwise = (sLit "ENT_DYN_FUN_DIRECT_ctr")
+ ctr | isStaticClosure cl_info = (fsLit "ENT_STATIC_FUN_DIRECT_ctr")
+ | otherwise = (fsLit "ENT_DYN_FUN_DIRECT_ctr")
registerTickyCtr :: CLabel -> FCode ()
-- Register a ticky counter
, mkStore (CmmLit (cmmLabelOffB ctr_lbl
oFFSET_StgEntCounter_registeredp))
(CmmLit (mkIntCLit 1)) ]
- ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel (sLit "ticky_entry_ctrs"))
+ ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel (fsLit "ticky_entry_ctrs"))
tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode ()
tickyReturnOldCon arity
- = ifTicky $ do { bumpTickyCounter (sLit "RET_OLD_ctr")
- ; bumpHistogram (sLit "RET_OLD_hst") arity }
+ = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
+ ; bumpHistogram (fsLit "RET_OLD_hst") arity }
tickyReturnNewCon arity
- = ifTicky $ do { bumpTickyCounter (sLit "RET_NEW_ctr")
- ; bumpHistogram (sLit "RET_NEW_hst") arity }
+ = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
+ ; bumpHistogram (fsLit "RET_NEW_hst") arity }
tickyUnboxedTupleReturn :: Int -> FCode ()
tickyUnboxedTupleReturn arity
- = ifTicky $ do { bumpTickyCounter (sLit "RET_UNBOXED_TUP_ctr")
- ; bumpHistogram (sLit "RET_UNBOXED_TUP_hst") arity }
+ = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
+ ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity }
tickyVectoredReturn :: Int -> FCode ()
tickyVectoredReturn family_size
- = ifTicky $ do { bumpTickyCounter (sLit "VEC_RETURN_ctr")
- ; bumpHistogram (sLit "RET_VEC_RETURN_hst") family_size }
+ = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr")
+ ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size }
-- -----------------------------------------------------------------------------
-- Ticky calls
tickySlowCallPat (map argPrimRep (drop arity args))
tickyKnownCallTooFewArgs :: FCode ()
-tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
+tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
+
tickyKnownCallExact :: FCode ()
-tickyKnownCallExact = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_ctr")
+tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
+
tickyKnownCallExtraArgs :: FCode ()
-tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_EXTRA_ARGS_ctr")
+tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
+
tickyUnknownCall :: FCode ()
-tickyUnknownCall = ifTicky $ bumpTickyCounter (sLit "UNKNOWN_CALL_ctr")
+tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
-- Tick for the call pattern at slow call site (i.e. in addition to
-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
(CmmLit (cmmLabelOffB ticky_ctr
oFFSET_StgEntCounter_allocs)) hp,
-- Bump ALLOC_HEAP_ctr
- addToMemLbl cLong (mkRtsDataLabel (sLit "ALLOC_HEAP_ctr")) 1,
+ addToMemLbl cLong (mkRtsDataLabel (fsLit "ALLOC_HEAP_ctr")) 1,
-- Bump ALLOC_HEAP_tot
- addToMemLbl cLong (mkRtsDataLabel (sLit "ALLOC_HEAP_tot")) hp] }
+ addToMemLbl cLong (mkRtsDataLabel (fsLit "ALLOC_HEAP_tot")) hp] }
-- -----------------------------------------------------------------------------
-- Ticky utils
else nopC
-- All the ticky-ticky counters are declared "unsigned long" in C
-bumpTickyCounter :: LitString -> FCode ()
+bumpTickyCounter :: FastString -> FCode ()
bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0)
bumpTickyCounter' :: CmmLit -> FCode ()
-- krc: note that we're incrementing the _entry_count_ field of the ticky counter
bumpTickyCounter' lhs = emit (addToMem cLong (CmmLit lhs) 1)
-bumpHistogram :: LitString -> Int -> FCode ()
+bumpHistogram :: FastString -> Int -> FCode ()
bumpHistogram _lbl _n
-- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth))
= return () -- TEMP SPJ Apr 07
--
-------------------------------------------------------------------------
-emitRtsCall :: LitString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
+emitRtsCall :: FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
-- The 'Nothing' says "save all global registers"
-emitRtsCallWithVols :: LitString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
+emitRtsCallWithVols :: FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
emitRtsCallWithVols fun args vols safe
= emitRtsCall' [] fun args (Just vols) safe
-emitRtsCallWithResult :: LocalReg -> ForeignHint -> LitString
+emitRtsCallWithResult :: LocalReg -> ForeignHint -> FastString
-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCallWithResult res hint fun args safe
= emitRtsCall' [(res,hint)] fun args Nothing safe
-- Make a call to an RTS C procedure
emitRtsCall'
:: [(LocalReg,ForeignHint)]
- -> LitString
+ -> FastString
-> [(CmmExpr,ForeignHint)]
-> Maybe [GlobalReg]
-> Bool -- True <=> CmmSafe call
projects / ghc-hetmet.git / commitdiff