Skip to content

GitLab

GHC
GHC
Commit 984a2881 authored by Ben.Lippmeier@anu.edu.au's avatar Ben.Lippmeier@anu.edu.au
Browse files
Options

Merge RtsLabelInfo.Rts* with RtsLabelInfo.Rts*FS

parent 6e232f49
Hide whitespace changes
Inline Side-by-side
Showing with 215 additions and 257 deletions
compiler/cmm/CLabel.hs
View file @ 984a2881
......@@ -81,13 +81,6 @@ module CLabel (
mkRtsDataLabel,
mkRtsGcPtrLabel,
mkRtsInfoLabelFS,
mkRtsEntryLabelFS,
mkRtsRetInfoLabelFS,
mkRtsRetLabelFS,
mkRtsCodeLabelFS,
mkRtsDataLabelFS,
mkRtsApFastLabel,
mkPrimCallLabel,
......@@ -273,22 +266,15 @@ data RtsLabelInfo
| 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
......@@ -355,17 +341,17 @@ mkModuleInitTableLabel mod = ModuleInitTableLabel mod
-- 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
......@@ -411,13 +397,6 @@ mkRtsCodeLabel str = RtsLabel (RtsCode str)
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
......@@ -449,25 +428,21 @@ mkDeadStripPreventer lbl = DeadStripPreventer lbl
-- 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
......@@ -669,23 +644,17 @@ labelType (RtsLabel (RtsInfo _)) = DataLabel
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
......@@ -836,13 +805,11 @@ pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLi
-- 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),
......@@ -873,27 +840,15 @@ pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
]
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))
......
compiler/cmm/CmmBuildInfoTables.hs
View file @ 984a2881
......@@ -518,8 +518,8 @@ lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do
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 <*>
......
compiler/cmm/CmmCPSGen.hs
View file @ 984a2881
......@@ -259,8 +259,8 @@ foreignCall uniques call results arguments =
-- 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.
......
compiler/cmm/CmmParse.y
View file @ 984a2881
......@@ -190,7 +190,7 @@ statics :: { [ExtFCode [CmmStatic]] }
-- 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
......@@ -243,13 +243,13 @@ cmmproc :: { ExtCode }
$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),
[]) }
......@@ -257,7 +257,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| '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
......@@ -271,7 +271,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| '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))
......@@ -286,7 +286,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-- 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),
[]) }
......@@ -294,15 +294,15 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| '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),
[]) }
......@@ -310,7 +310,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| '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) }
......@@ -852,7 +852,7 @@ lookupName name = do
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
......@@ -886,8 +886,8 @@ profilingInfo desc_str ty_str = do
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
......
compiler/codeGen/CgCallConv.hs
View file @ 984a2881
......@@ -209,7 +209,7 @@ constructSlowCall
-- don't forget the zero case
constructSlowCall []
= (mkRtsApFastLabel (sLit "stg_ap_0"), [], [])
= (mkRtsApFastLabel (fsLit "stg_ap_0"), [], [])
constructSlowCall amodes
= (stg_ap_pat, these, rest)
......@@ -227,28 +227,28 @@ slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs 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"
-------------------------------------------------------------------------
--
......
compiler/codeGen/CgClosure.lhs
View file @ 984a2881
......@@ -560,7 +560,7 @@ link_caf cl_info _is_upd = do
-- 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
......
compiler/codeGen/CgCon.lhs
View file @ 984a2881
......@@ -170,7 +170,7 @@ buildDynCon binder _ con [arg_amode]
, (_, 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)
......@@ -181,7 +181,7 @@ buildDynCon binder _ con [arg_amode]
, (_, 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)
......
compiler/codeGen/CgForeignCall.hs
View file @ 984a2881
......@@ -144,8 +144,8 @@ emitForeignCall' safety results target args vols _srt ret
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
......
compiler/codeGen/CgHeapery.lhs
View file @ 984a2881
......@@ -346,7 +346,7 @@ altHeapCheck alt_type code
; 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)
......@@ -360,14 +360,14 @@ altHeapCheck alt_type code
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}
......@@ -405,7 +405,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code 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}
......@@ -514,7 +514,7 @@ stkChkNodePoints bytes
= 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}
......
compiler/codeGen/CgPrimOp.hs
View file @ 984a2881
......@@ -122,7 +122,7 @@ emitPrimOp [res] ParOp [arg] live
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))
......
compiler/codeGen/CgProf.hs
View file @ 984a2881
......@@ -65,7 +65,7 @@ curCCS = CmmLoad curCCSAddr bWord
-- 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)
......@@ -260,7 +260,7 @@ enterCostCentreThunk closure =
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
......@@ -273,7 +273,7 @@ enter_ccs_fsub = enteringPAP 0
-- 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
......@@ -389,12 +389,12 @@ emitRegisterCCS ccs = do
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
......@@ -413,7 +413,7 @@ emitSetCCC cc
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
......@@ -479,7 +479,7 @@ ldvEnter cl_ptr
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
......
compiler/codeGen/CgTicky.hs
View file @ 984a2881
......@@ -117,19 +117,19 @@ ppr_for_ticky_name mod_name name
-- 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
......@@ -140,15 +140,15 @@ tickyBlackHole :: Bool{-updatable-} -> Code
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
......@@ -159,8 +159,8 @@ 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
......@@ -183,25 +183,25 @@ registerTickyCtr ctr_lbl
, 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 }
-- -----------------------------------------------------------------------------