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 ( ...@@ -81,13 +81,6 @@ module CLabel (
mkRtsDataLabel, mkRtsDataLabel,
mkRtsGcPtrLabel, mkRtsGcPtrLabel,
mkRtsInfoLabelFS,
mkRtsEntryLabelFS,
mkRtsRetInfoLabelFS,
mkRtsRetLabelFS,
mkRtsCodeLabelFS,
mkRtsDataLabelFS,
mkRtsApFastLabel, mkRtsApFastLabel,
mkPrimCallLabel, mkPrimCallLabel,
...@@ -273,22 +266,15 @@ data RtsLabelInfo ...@@ -273,22 +266,15 @@ data RtsLabelInfo
| RtsPrimOp PrimOp | RtsPrimOp PrimOp
| RtsInfo LitString -- misc rts info tables | RtsInfo FastString -- misc rts info tables
| RtsEntry LitString -- misc rts entry points | RtsEntry FastString -- misc rts entry points
| RtsRetInfo LitString -- misc rts ret info tables | RtsRetInfo FastString -- misc rts ret info tables
| RtsRet LitString -- misc rts return points | RtsRet FastString -- misc rts return points
| RtsData LitString -- misc rts data bits | RtsData FastString -- misc rts data bits, eg CHARLIKE_closure
| RtsGcPtr LitString -- GcPtrs eg CHARLIKE_closure | RtsCode FastString -- misc rts code
| RtsCode LitString -- misc rts code | RtsGcPtr FastString -- GcPtrs eg CHARLIKE_closure
| 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
| RtsApFast LitString -- _fast versions of generic apply | RtsApFast FastString -- _fast versions of generic apply
| RtsSlowTickyCtr String | RtsSlowTickyCtr String
...@@ -355,17 +341,17 @@ mkModuleInitTableLabel mod = ModuleInitTableLabel mod ...@@ -355,17 +341,17 @@ mkModuleInitTableLabel mod = ModuleInitTableLabel mod
-- Some fixed runtime system labels -- Some fixed runtime system labels
mkSplitMarkerLabel = RtsLabel (RtsCode (sLit "__stg_split_marker")) mkSplitMarkerLabel = RtsLabel (RtsCode (fsLit "__stg_split_marker"))
mkDirty_MUT_VAR_Label = RtsLabel (RtsCode (sLit "dirty_MUT_VAR")) mkDirty_MUT_VAR_Label = RtsLabel (RtsCode (fsLit "dirty_MUT_VAR"))
mkUpdInfoLabel = RtsLabel (RtsInfo (sLit "stg_upd_frame")) mkUpdInfoLabel = RtsLabel (RtsInfo (fsLit "stg_upd_frame"))
mkIndStaticInfoLabel = RtsLabel (RtsInfo (sLit "stg_IND_STATIC")) mkIndStaticInfoLabel = RtsLabel (RtsInfo (fsLit "stg_IND_STATIC"))
mkMainCapabilityLabel = RtsLabel (RtsData (sLit "MainCapability")) mkMainCapabilityLabel = RtsLabel (RtsData (fsLit "MainCapability"))
mkMAP_FROZEN_infoLabel = RtsLabel (RtsInfo (sLit "stg_MUT_ARR_PTRS_FROZEN0")) mkMAP_FROZEN_infoLabel = RtsLabel (RtsInfo (fsLit "stg_MUT_ARR_PTRS_FROZEN0"))
mkMAP_DIRTY_infoLabel = RtsLabel (RtsInfo (sLit "stg_MUT_ARR_PTRS_DIRTY")) mkMAP_DIRTY_infoLabel = RtsLabel (RtsInfo (fsLit "stg_MUT_ARR_PTRS_DIRTY"))
mkEMPTY_MVAR_infoLabel = RtsLabel (RtsInfo (sLit "stg_EMPTY_MVAR")) mkEMPTY_MVAR_infoLabel = RtsLabel (RtsInfo (fsLit "stg_EMPTY_MVAR"))
mkTopTickyCtrLabel = RtsLabel (RtsData (sLit "top_ct")) mkTopTickyCtrLabel = RtsLabel (RtsData (fsLit "top_ct"))
mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsInfo (sLit "stg_CAF_BLACKHOLE")) mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsInfo (fsLit "stg_CAF_BLACKHOLE"))
mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
moduleRegdLabel = ModuleRegdLabel moduleRegdLabel = ModuleRegdLabel
...@@ -411,13 +397,6 @@ mkRtsCodeLabel str = RtsLabel (RtsCode str) ...@@ -411,13 +397,6 @@ mkRtsCodeLabel str = RtsLabel (RtsCode str)
mkRtsDataLabel str = RtsLabel (RtsData str) mkRtsDataLabel str = RtsLabel (RtsData str)
mkRtsGcPtrLabel str = RtsLabel (RtsGcPtr 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) mkRtsApFastLabel str = RtsLabel (RtsApFast str)
mkRtsSlowTickyCtrLabel :: String -> CLabel mkRtsSlowTickyCtrLabel :: String -> CLabel
...@@ -449,25 +428,21 @@ mkDeadStripPreventer lbl = DeadStripPreventer lbl ...@@ -449,25 +428,21 @@ mkDeadStripPreventer lbl = DeadStripPreventer lbl
-- Converting between info labels and entry/ret labels. -- Converting between info labels and entry/ret labels.
infoLblToEntryLbl :: CLabel -> CLabel infoLblToEntryLbl :: CLabel -> CLabel
infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry
infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry
infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry
infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s) infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s)
infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s) infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s)
infoLblToEntryLbl (RtsLabel (RtsInfoFS s)) = RtsLabel (RtsEntryFS s)
infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s)
infoLblToEntryLbl _ = panic "CLabel.infoLblToEntryLbl" infoLblToEntryLbl _ = panic "CLabel.infoLblToEntryLbl"
entryLblToInfoLbl :: CLabel -> CLabel entryLblToInfoLbl :: CLabel -> CLabel
entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable
entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable
entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable
entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s) entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s)
entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s) entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s)
entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s)
entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s)
entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l) entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure
...@@ -669,23 +644,17 @@ labelType (RtsLabel (RtsInfo _)) = DataLabel ...@@ -669,23 +644,17 @@ labelType (RtsLabel (RtsInfo _)) = DataLabel
labelType (RtsLabel (RtsEntry _)) = CodeLabel labelType (RtsLabel (RtsEntry _)) = CodeLabel
labelType (RtsLabel (RtsRetInfo _)) = DataLabel labelType (RtsLabel (RtsRetInfo _)) = DataLabel
labelType (RtsLabel (RtsRet _)) = CodeLabel labelType (RtsLabel (RtsRet _)) = CodeLabel
labelType (RtsLabel (RtsDataFS _)) = DataLabel labelType (RtsLabel (RtsApFast _)) = CodeLabel
labelType (RtsLabel (RtsCodeFS _)) = CodeLabel labelType (CaseLabel _ CaseReturnInfo) = DataLabel
labelType (RtsLabel (RtsInfoFS _)) = DataLabel labelType (CaseLabel _ _) = CodeLabel
labelType (RtsLabel (RtsEntryFS _)) = CodeLabel labelType (ModuleInitLabel _ _) = CodeLabel
labelType (RtsLabel (RtsRetInfoFS _)) = DataLabel labelType (PlainModuleInitLabel _) = CodeLabel
labelType (RtsLabel (RtsRetFS _)) = CodeLabel labelType (ModuleInitTableLabel _) = DataLabel
labelType (RtsLabel (RtsApFast _)) = CodeLabel labelType (LargeSRTLabel _) = DataLabel
labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (LargeBitmapLabel _) = DataLabel
labelType (CaseLabel _ _) = CodeLabel labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
labelType (ModuleInitLabel _ _) = CodeLabel labelType (IdLabel _ _ info) = idInfoLabelType info
labelType (PlainModuleInitLabel _) = CodeLabel labelType _ = DataLabel
labelType (ModuleInitTableLabel _) = DataLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
labelType (IdLabel _ _ info) = idInfoLabelType info
labelType _ = DataLabel
idInfoLabelType info = idInfoLabelType info =
case info of case info of
...@@ -836,13 +805,11 @@ pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLi ...@@ -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. -- with a letter so the label will be legal assmbly code.
pprCLbl (RtsLabel (RtsCode str)) = ptext str pprCLbl (RtsLabel (RtsCode str)) = ftext str
pprCLbl (RtsLabel (RtsData str)) = ptext str pprCLbl (RtsLabel (RtsData str)) = ftext str
pprCLbl (RtsLabel (RtsGcPtr str)) = ptext str pprCLbl (RtsLabel (RtsGcPtr str)) = ftext str
pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str
pprCLbl (RtsLabel (RtsDataFS 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)) pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
= hcat [ptext (sLit "stg_sel_"), text (show offset), = hcat [ptext (sLit "stg_sel_"), text (show offset),
...@@ -873,27 +840,15 @@ pprCLbl (RtsLabel (RtsApEntry upd_reqd arity)) ...@@ -873,27 +840,15 @@ pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
] ]
pprCLbl (RtsLabel (RtsInfo fs)) 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") = ftext fs <> ptext (sLit "_info")
pprCLbl (RtsLabel (RtsEntryFS fs)) pprCLbl (RtsLabel (RtsEntry fs))
= ftext fs <> ptext (sLit "_entry") = ftext fs <> ptext (sLit "_entry")
pprCLbl (RtsLabel (RtsRetInfoFS fs)) pprCLbl (RtsLabel (RtsRetInfo fs))
= ftext fs <> ptext (sLit "_info") = ftext fs <> ptext (sLit "_info")
pprCLbl (RtsLabel (RtsRetFS fs)) pprCLbl (RtsLabel (RtsRet fs))
= ftext fs <> ptext (sLit "_ret") = ftext fs <> ptext (sLit "_ret")
pprCLbl (RtsLabel (RtsPrimOp primop)) pprCLbl (RtsLabel (RtsPrimOp primop))
......
compiler/cmm/CmmBuildInfoTables.hs
View file @ 984a2881
...@@ -518,8 +518,8 @@ lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do ...@@ -518,8 +518,8 @@ lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do
new_base <- newTemp (cmmRegType (CmmGlobal BaseReg)) new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
let (caller_save, caller_load) = callerSaveVolatileRegs let (caller_save, caller_load) = callerSaveVolatileRegs
load_tso <- newTemp gcWord -- TODO FIXME NOW load_tso <- newTemp gcWord -- TODO FIXME NOW
let suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread"))) let suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "suspendThread")))
resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread"))) resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "resumeThread")))
suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*> suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*>
saveThreadState <*> saveThreadState <*>
caller_save <*> caller_save <*>
......
compiler/cmm/CmmCPSGen.hs
View file @ 984a2881
...@@ -259,8 +259,8 @@ foreignCall uniques call results arguments = ...@@ -259,8 +259,8 @@ foreignCall uniques call results arguments =
-- Save/restore the thread state in the TSO -- Save/restore the thread state in the TSO
suspendThread, resumeThread :: CmmExpr suspendThread, resumeThread :: CmmExpr
suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread"))) suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "suspendThread")))
resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread"))) resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "resumeThread")))
-- This stuff can't be done in suspendThread/resumeThread, because it -- This stuff can't be done in suspendThread/resumeThread, because it
-- refers to global registers which aren't available in the C world. -- 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]] } ...@@ -190,7 +190,7 @@ statics :: { [ExtFCode [CmmStatic]] }
-- Strings aren't used much in the RTS HC code, so it doesn't seem -- 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. -- worth allowing inline strings. C-- doesn't allow them anyway.
static :: { ExtFCode [CmmStatic] } static :: { ExtFCode [CmmStatic] }
: NAME ':' { return [CmmDataLabel (mkRtsDataLabelFS $1)] } : NAME ':' { return [CmmDataLabel (mkRtsDataLabel $1)] }
| type expr ';' { do e <- $2; | type expr ';' { do e <- $2;
return [CmmStaticLit (getLit e)] } return [CmmStaticLit (getLit e)] }
| type ';' { return [CmmUninitialised | type ';' { return [CmmUninitialised
...@@ -243,13 +243,13 @@ cmmproc :: { ExtCode } ...@@ -243,13 +243,13 @@ cmmproc :: { ExtCode }
$6; $6;
return (formals, gc_block, frame) } return (formals, gc_block, frame) }
blks <- code (cgStmtsToBlocks stmts) 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 :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type -- ptrs, nptrs, closure type, description, type
{ do prof <- profilingInfo $11 $13 { do prof <- profilingInfo $11 $13
return (mkRtsEntryLabelFS $3, return (mkRtsEntryLabel $3,
CmmInfoTable False prof (fromIntegral $9) CmmInfoTable False prof (fromIntegral $9)
(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT), (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
[]) } []) }
...@@ -257,7 +257,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } ...@@ -257,7 +257,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type -- ptrs, nptrs, closure type, description, type, fun type
{ do prof <- profilingInfo $11 $13 { do prof <- profilingInfo $11 $13
return (mkRtsEntryLabelFS $3, return (mkRtsEntryLabel $3,
CmmInfoTable False prof (fromIntegral $9) CmmInfoTable False prof (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT
0 -- Arity zero 0 -- Arity zero
...@@ -271,7 +271,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } ...@@ -271,7 +271,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')' | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type, arity -- ptrs, nptrs, closure type, description, type, fun type, arity
{ do prof <- profilingInfo $11 $13 { do prof <- profilingInfo $11 $13
return (mkRtsEntryLabelFS $3, return (mkRtsEntryLabel $3,
CmmInfoTable False prof (fromIntegral $9) CmmInfoTable False prof (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17)
(ArgSpec (fromIntegral $15)) (ArgSpec (fromIntegral $15))
...@@ -286,7 +286,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } ...@@ -286,7 +286,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-- If profiling is on, this string gets duplicated, -- 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. -- but that's the way the old code did it we can fix it some other time.
desc_lit <- code $ mkStringCLit $13 desc_lit <- code $ mkStringCLit $13
return (mkRtsEntryLabelFS $3, return (mkRtsEntryLabel $3,
CmmInfoTable False prof (fromIntegral $11) CmmInfoTable False prof (fromIntegral $11)
(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit), (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
[]) } []) }
...@@ -294,15 +294,15 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } ...@@ -294,15 +294,15 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type -- selector, closure type, description, type
{ do prof <- profilingInfo $9 $11 { do prof <- profilingInfo $9 $11
return (mkRtsEntryLabelFS $3, return (mkRtsEntryLabel $3,
CmmInfoTable False prof (fromIntegral $7) CmmInfoTable False prof (fromIntegral $7)
(ThunkSelectorInfo (fromIntegral $5) NoC_SRT), (ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
[]) } []) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ')' | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
-- closure type (no live regs) -- closure type (no live regs)
{ do let infoLabel = mkRtsInfoLabelFS $3 { do let infoLabel = mkRtsInfoLabel $3
return (mkRtsRetLabelFS $3, return (mkRtsRetLabel $3,
CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
(ContInfo [] NoC_SRT), (ContInfo [] NoC_SRT),
[]) } []) }
...@@ -310,7 +310,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } ...@@ -310,7 +310,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')' | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
-- closure type, live regs -- closure type, live regs
{ do live <- sequence (map (liftM Just) $7) { do live <- sequence (map (liftM Just) $7)
return (mkRtsRetLabelFS $3, return (mkRtsRetLabel $3,
CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
(ContInfo live NoC_SRT), (ContInfo live NoC_SRT),
live) } live) }
...@@ -852,7 +852,7 @@ lookupName name = do ...@@ -852,7 +852,7 @@ lookupName name = do
return $ return $
case lookupUFM env name of case lookupUFM env name of
Just (Var e) -> e Just (Var e) -> e
_other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name)) _other -> CmmLit (CmmLabel (mkRtsCodeLabel name))
-- Lifting FCode computations into the ExtFCode monad: -- Lifting FCode computations into the ExtFCode monad:
code :: FCode a -> ExtFCode a code :: FCode a -> ExtFCode a
...@@ -886,8 +886,8 @@ profilingInfo desc_str ty_str = do ...@@ -886,8 +886,8 @@ profilingInfo desc_str ty_str = do
staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
staticClosure cl_label info payload staticClosure cl_label info payload
= code $ emitDataLits (mkRtsDataLabelFS cl_label) lits = code $ emitDataLits (mkRtsDataLabel cl_label) lits
where lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] [] where lits = mkStaticClosure (mkRtsInfoLabel info) dontCareCCS payload [] [] []
foreignCall foreignCall
:: String :: String
......
compiler/codeGen/CgCallConv.hs
View file @ 984a2881
...@@ -209,7 +209,7 @@ constructSlowCall ...@@ -209,7 +209,7 @@ constructSlowCall
-- don't forget the zero case -- don't forget the zero case
constructSlowCall [] constructSlowCall []
= (mkRtsApFastLabel (sLit "stg_ap_0"), [], []) = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], [])
constructSlowCall amodes constructSlowCall amodes
= (stg_ap_pat, these, rest) = (stg_ap_pat, these, rest)
...@@ -227,28 +227,28 @@ slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest ...@@ -227,28 +227,28 @@ slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest
stg_ap_pat = mkRtsRetInfoLabel arg_pat stg_ap_pat = mkRtsRetInfoLabel arg_pat
matchSlowPattern :: [(CgRep,CmmExpr)] matchSlowPattern :: [(CgRep,CmmExpr)]
-> (LitString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)]) -> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
matchSlowPattern amodes = (arg_pat, these, rest) matchSlowPattern amodes = (arg_pat, these, rest)
where (arg_pat, n) = slowCallPattern (map fst amodes) where (arg_pat, n) = slowCallPattern (map fst amodes)
(these, rest) = splitAt n amodes (these, rest) = splitAt n amodes
-- These cases were found to cover about 99% of all slow calls: -- These cases were found to cover about 99% of all slow calls:
slowCallPattern :: [CgRep] -> (LitString, Int) slowCallPattern :: [CgRep] -> (FastString, Int)
slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_pppppp", 6) slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppppp", 6)
slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_ppppp", 5) slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppppp", 5)
slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_pppp", 4) slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppp", 4)
slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (sLit "stg_ap_pppv", 4) slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_pppv", 4)
slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_ppp", 3) slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppp", 3)
slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (sLit "stg_ap_ppv", 3) slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_ppv", 3)
slowCallPattern (PtrArg: PtrArg: _) = (sLit "stg_ap_pp", 2) slowCallPattern (PtrArg: PtrArg: _) = (fsLit "stg_ap_pp", 2)
slowCallPattern (PtrArg: VoidArg: _) = (sLit "stg_ap_pv", 2) slowCallPattern (PtrArg: VoidArg: _) = (fsLit "stg_ap_pv", 2)
slowCallPattern (PtrArg: _) = (sLit "stg_ap_p", 1) slowCallPattern (PtrArg: _) = (fsLit "stg_ap_p", 1)
slowCallPattern (VoidArg: _) = (sLit "stg_ap_v", 1) slowCallPattern (VoidArg: _) = (fsLit "stg_ap_v", 1)
slowCallPattern (NonPtrArg: _) = (sLit "stg_ap_n", 1) slowCallPattern (NonPtrArg: _) = (fsLit "stg_ap_n", 1)
slowCallPattern (FloatArg: _) = (sLit "stg_ap_f", 1) slowCallPattern (FloatArg: _) = (fsLit "stg_ap_f", 1)
slowCallPattern (DoubleArg: _) = (sLit "stg_ap_d", 1) slowCallPattern (DoubleArg: _) = (fsLit "stg_ap_d", 1)
slowCallPattern (LongArg: _) = (sLit "stg_ap_l", 1) slowCallPattern (LongArg: _) = (fsLit "stg_ap_l", 1)
slowCallPattern _ = panic "CgStackery.slowCallPattern" slowCallPattern _ = panic "CgStackery.slowCallPattern"
------------------------------------------------------------------------- -------------------------------------------------------------------------
-- --
......
compiler/codeGen/CgClosure.lhs
View file @ 984a2881
...@@ -560,7 +560,7 @@ link_caf cl_info _is_upd = do ...@@ -560,7 +560,7 @@ link_caf cl_info _is_upd = do
-- so that the garbage collector can find them -- so that the garbage collector can find them
-- This must be done *before* the info table pointer is overwritten, -- This must be done *before* the info table pointer is overwritten,
-- because the old info table ptr is needed for reversion -- 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. -- node is live, so save it.
-- Overwrite the closure with a (static) indirection -- Overwrite the closure with a (static) indirection
......
compiler/codeGen/CgCon.lhs
View file @ 984a2881
...@@ -170,7 +170,7 @@ buildDynCon binder _ con [arg_amode] ...@@ -170,7 +170,7 @@ buildDynCon binder _ con [arg_amode]
, (_, CmmLit (CmmInt val _)) <- arg_amode , (_, CmmLit (CmmInt val _)) <- arg_amode
, let val_int = (fromIntegral val) :: Int , let val_int = (fromIntegral val) :: Int
, val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE , 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) offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
-- INTLIKE closures consist of a header and one word payload -- INTLIKE closures consist of a header and one word payload
intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW) intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW)
...@@ -181,7 +181,7 @@ buildDynCon binder _ con [arg_amode] ...@@ -181,7 +181,7 @@ buildDynCon binder _ con [arg_amode]
, (_, CmmLit (CmmInt val _)) <- arg_amode , (_, CmmLit (CmmInt val _)) <- arg_amode
, let val_int = (fromIntegral val) :: Int , let val_int = (fromIntegral val) :: Int
, val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE , 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) offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
-- CHARLIKE closures consist of a header and one word payload -- CHARLIKE closures consist of a header and one word payload
charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW) 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 ...@@ -144,8 +144,8 @@ emitForeignCall' safety results target args vols _srt ret
emitLoadThreadState emitLoadThreadState
suspendThread, resumeThread :: CmmExpr suspendThread, resumeThread :: CmmExpr
suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread"))) suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "suspendThread")))
resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread"))) resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "resumeThread")))
-- we might need to load arguments into temporaries before -- we might need to load arguments into temporaries before
......
compiler/codeGen/CgHeapery.lhs
View file @ 984a2881
...@@ -346,7 +346,7 @@ altHeapCheck alt_type code ...@@ -346,7 +346,7 @@ altHeapCheck alt_type code
; setRealHp hpHw ; setRealHp hpHw
; code } ; code }
where 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 -- Do *not* enter R1 after a heap check in
-- a polymorphic case. It might be a function -- a polymorphic case. It might be a function
-- and the entry code for a function (currently) -- and the entry code for a function (currently)
...@@ -360,14 +360,14 @@ altHeapCheck alt_type code ...@@ -360,14 +360,14 @@ altHeapCheck alt_type code
rts_label (PrimAlt tc) rts_label (PrimAlt tc)
= CmmLit $ CmmLabel $ = CmmLit $ CmmLabel $
case primRepToCgRep (tyConPrimRep tc) of case primRepToCgRep (tyConPrimRep tc) of
VoidArg -> mkRtsCodeLabel (sLit "stg_gc_noregs") VoidArg -> mkRtsCodeLabel (fsLit "stg_gc_noregs")
FloatArg -> mkRtsCodeLabel (sLit "stg_gc_f1") FloatArg -> mkRtsCodeLabel (fsLit "stg_gc_f1")
DoubleArg -> mkRtsCodeLabel (sLit "stg_gc_d1") DoubleArg -> mkRtsCodeLabel (fsLit "stg_gc_d1")
LongArg -> mkRtsCodeLabel (sLit "stg_gc_l1") LongArg -> mkRtsCodeLabel (fsLit "stg_gc_l1")
-- R1 is boxed but unlifted: -- R1 is boxed but unlifted:
PtrArg -> mkRtsCodeLabel (sLit "stg_gc_unpt_r1") PtrArg -> mkRtsCodeLabel (fsLit "stg_gc_unpt_r1")
-- R1 is unboxed: -- R1 is unboxed:
NonPtrArg -> mkRtsCodeLabel (sLit "stg_gc_unbx_r1") NonPtrArg -> mkRtsCodeLabel (fsLit "stg_gc_unbx_r1")
rts_label (UbxTupAlt _) = panic "altHeapCheck" rts_label (UbxTupAlt _) = panic "altHeapCheck"
\end{code} \end{code}
...@@ -405,7 +405,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code ...@@ -405,7 +405,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code
assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho!
(CmmLit (mkWordCLit liveness)) (CmmLit (mkWordCLit liveness))
liveness = mkRegLiveness regs ptrs nptrs 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} \end{code}
...@@ -514,7 +514,7 @@ stkChkNodePoints bytes ...@@ -514,7 +514,7 @@ stkChkNodePoints bytes
= do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1 = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1
stg_gc_gen :: CmmExpr 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 :: CmmExpr
stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
\end{code} \end{code}
......
compiler/codeGen/CgPrimOp.hs
View file @ 984a2881
...@@ -122,7 +122,7 @@ emitPrimOp [res] ParOp [arg] live ...@@ -122,7 +122,7 @@ emitPrimOp [res] ParOp [arg] live
NoC_SRT -- No SRT b/c we do PlayRisky NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn CmmMayReturn
where where
newspark = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "newSpark"))) newspark = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "newSpark")))
emitPrimOp [res] ReadMutVarOp [mutv] _ emitPrimOp [res] ReadMutVarOp [mutv] _
= stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord))
......
compiler/codeGen/CgProf.hs
View file @ 984a2881
...@@ -65,7 +65,7 @@ curCCS = CmmLoad curCCSAddr bWord ...@@ -65,7 +65,7 @@ curCCS = CmmLoad curCCSAddr bWord