summaryrefslogtreecommitdiff
path: root/compiler/GHC/StgToCmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/StgToCmm')
-rw-r--r--compiler/GHC/StgToCmm/Bind.hs8
-rw-r--r--compiler/GHC/StgToCmm/DataCon.hs11
-rw-r--r--compiler/GHC/StgToCmm/Heap.hs4
-rw-r--r--compiler/GHC/StgToCmm/Hpc.hs2
-rw-r--r--compiler/GHC/StgToCmm/Prof.hs4
-rw-r--r--compiler/GHC/StgToCmm/Ticky.hs2
-rw-r--r--compiler/GHC/StgToCmm/Utils.hs49
7 files changed, 51 insertions, 29 deletions
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index a78ab5cb41..977fa4649e 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -87,15 +87,11 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body =
-- hole detection from working in that case. Test
-- concurrent/should_run/4030 fails, for instance.
--
- gen_code dflags _ closure_label
+ gen_code _ _ closure_label
| StgApp f [] <- body, null args, isNonRec rec
= do
cg_info <- getCgIdInfo f
- let closure_rep = mkStaticClosureFields dflags
- indStaticInfoTable ccs MayHaveCafRefs
- [unLit (idInfoToAmode cg_info)]
- emitDataLits closure_label closure_rep
- return ()
+ emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]
gen_code dflags lf_info _closure_label
= do { let name = idName id
diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs
index 2bbeabace6..7d86620708 100644
--- a/compiler/GHC/StgToCmm/DataCon.hs
+++ b/compiler/GHC/StgToCmm/DataCon.hs
@@ -104,17 +104,8 @@ cgTopRhsCon dflags id con args =
-- NB2: all the amodes should be Lits!
-- TODO (osa): Why?
- ; let closure_rep = mkStaticClosureFields
- dflags
- info_tbl
- dontCareCCS -- Because it's static data
- caffy -- Has CAF refs
- payload
-
-- BUILD THE OBJECT
- ; emitDataLits closure_label closure_rep
-
- ; return () }
+ ; emitDataCon closure_label info_tbl dontCareCCS payload }
---------------------------------------------------------------
diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs
index 0ac573314a..085d47219f 100644
--- a/compiler/GHC/StgToCmm/Heap.hs
+++ b/compiler/GHC/StgToCmm/Heap.hs
@@ -196,7 +196,9 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload
| otherwise = []
static_link_field
- | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl
+ | is_caf
+ = [mkIntCLit dflags 0]
+ | staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl
= [static_link_value]
| otherwise
= []
diff --git a/compiler/GHC/StgToCmm/Hpc.hs b/compiler/GHC/StgToCmm/Hpc.hs
index a3f4112206..219285efbe 100644
--- a/compiler/GHC/StgToCmm/Hpc.hs
+++ b/compiler/GHC/StgToCmm/Hpc.hs
@@ -41,7 +41,7 @@ initHpc _ (NoHpcInfo {})
initHpc this_mod (HpcInfo tickCount _hashNo)
= do dflags <- getDynFlags
when (gopt Opt_Hpc dflags) $
- do emitDataLits (mkHpcTicksLabel this_mod)
+ emitRawDataLits (mkHpcTicksLabel this_mod)
[ (CmmInt 0 W64)
| _ <- take tickCount [0 :: Int ..]
]
diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs
index cf5ce5acfb..581e8279dc 100644
--- a/compiler/GHC/StgToCmm/Prof.hs
+++ b/compiler/GHC/StgToCmm/Prof.hs
@@ -231,7 +231,7 @@ emitCostCentreDecl cc = do
is_caf, -- StgInt is_caf
zero dflags -- struct _CostCentre *link
]
- ; emitDataLits (mkCCLabel cc) lits
+ ; emitRawDataLits (mkCCLabel cc) lits
}
emitCostCentreStackDecl :: CostCentreStack -> FCode ()
@@ -247,7 +247,7 @@ emitCostCentreStackDecl ccs
-- layouts of structs containing long-longs, simply
-- pad out the struct with zero words until we hit the
-- size of the overall struct (which we get via DerivedConstants.h)
- emitDataLits (mkCCSLabel ccs) (mk_lits cc)
+ emitRawDataLits (mkCCSLabel ccs) (mk_lits cc)
Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
zero :: DynFlags -> CmmLit
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
index 6e2e2d3a6b..fbb121dae6 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -240,7 +240,7 @@ emitTickyCounter cloType name args
; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name
; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args
- ; emitDataLits ctr_lbl
+ ; emitRawDataLits ctr_lbl
-- Must match layout of includes/rts/Ticky.h's StgEntCounter
--
-- krc: note that all the fields are I32 now; some were I16
diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs
index 7a784ea85c..373beeed07 100644
--- a/compiler/GHC/StgToCmm/Utils.hs
+++ b/compiler/GHC/StgToCmm/Utils.hs
@@ -10,8 +10,9 @@
module GHC.StgToCmm.Utils (
cgLit, mkSimpleLit,
- emitDataLits, mkDataLits,
- emitRODataLits, mkRODataLits,
+ emitRawDataLits, mkRawDataLits,
+ emitRawRODataLits, mkRawRODataLits,
+ emitDataCon,
emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
assignTemp, newTemp,
@@ -36,7 +37,7 @@ module GHC.StgToCmm.Utils (
cmmUntag, cmmIsTagged,
addToMem, addToMemE, addToMemLblE, addToMemLbl,
- mkWordCLit,
+ mkWordCLit, mkByteStringCLit,
newStringCLit, newByteStringCLit,
blankWord,
@@ -57,7 +58,7 @@ import GHC.Cmm.BlockId
import GHC.Cmm.Graph as CmmGraph
import GHC.Platform.Regs
import GHC.Cmm.CLabel
-import GHC.Cmm.Utils
+import GHC.Cmm.Utils hiding (mkDataLits, mkRODataLits, mkByteStringCLit)
import GHC.Cmm.Switch
import GHC.StgToCmm.CgUtils
@@ -76,9 +77,11 @@ import DynFlags
import FastString
import Outputable
import GHC.Types.RepType
+import CostCentre
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString as BS
import qualified Data.Map as M
import Data.Char
import Data.List
@@ -270,13 +273,43 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load)
--
-------------------------------------------------------------------------
-emitDataLits :: CLabel -> [CmmLit] -> FCode ()
+mkRawDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
+-- Build a data-segment data block
+mkRawDataLits section lbl lits
+ = CmmData section (CmmStaticsRaw lbl (map CmmStaticLit lits))
+
+mkRawRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
+-- Build a read-only data block
+mkRawRODataLits lbl lits
+ = mkRawDataLits section lbl lits
+ where
+ section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
+ | otherwise = Section ReadOnlyData lbl
+ needsRelocation (CmmLabel _) = True
+ needsRelocation (CmmLabelOff _ _) = True
+ needsRelocation _ = False
+
+mkByteStringCLit
+ :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)
+-- We have to make a top-level decl for the string,
+-- and return a literal pointing to it
+mkByteStringCLit lbl bytes
+ = (CmmLabel lbl, CmmData (Section sec lbl) (CmmStaticsRaw lbl [CmmString bytes]))
+ where
+ -- This can not happen for String literals (as there \NUL is replaced by
+ -- C0 80). However, it can happen with Addr# literals.
+ sec = if 0 `BS.elem` bytes then ReadOnlyData else CString
+
+emitRawDataLits :: CLabel -> [CmmLit] -> FCode ()
-- Emit a data-segment data block
-emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
+emitRawDataLits lbl lits = emitDecl (mkRawDataLits (Section Data lbl) lbl lits)
-emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
+emitRawRODataLits :: CLabel -> [CmmLit] -> FCode ()
-- Emit a read-only data block
-emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
+emitRawRODataLits lbl lits = emitDecl (mkRawRODataLits lbl lits)
+
+emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
+emitDataCon lbl itbl ccs payload = emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload))
newStringCLit :: String -> FCode CmmLit
-- Make a global definition for the string,
View Lorry Controller Status