summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/CLabel.hs141
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs4
-rw-r--r--compiler/cmm/CmmCPSGen.hs4
-rw-r--r--compiler/cmm/CmmParse.y26
4 files changed, 65 insertions, 110 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index a78c22f8ec..181071f7a0 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -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))
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 1a4a591d68..6b0df700c2 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -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 <*>
diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs
index eb754aeb23..5d691f8e5c 100644
--- a/compiler/cmm/CmmCPSGen.hs
+++ b/compiler/cmm/CmmCPSGen.hs
@@ -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.
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 3cd6be97a2..0783fc4ce1 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -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
View Lorry Controller Status