summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/CLabel.hs50
-rw-r--r--compiler/cmm/Cmm.hs5
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs12
-rw-r--r--compiler/cmm/CmmInfo.hs104
-rw-r--r--compiler/cmm/CmmLayoutStack.hs2
-rw-r--r--compiler/cmm/CmmLex.x208
-rw-r--r--compiler/cmm/CmmMachOp.hs19
-rw-r--r--compiler/cmm/CmmParse.y4
-rw-r--r--compiler/cmm/CmmPipeline.hs7
-rw-r--r--compiler/cmm/CmmSink.hs4
-rw-r--r--compiler/cmm/PprC.hs4
-rw-r--r--compiler/cmm/PprCmm.hs3
12 files changed, 223 insertions, 199 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 407002f1c7..02ad026249 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -158,14 +158,14 @@ data CLabel
-- | A label from a .cmm file that is not associated with a .hs level Id.
| CmmLabel
- PackageId -- what package the label belongs to.
+ PackageKey -- what package the label belongs to.
FastString -- identifier giving the prefix of the label
CmmLabelInfo -- encodes the suffix of the label
-- | A label with a baked-in \/ algorithmically generated name that definitely
-- comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so
-- If it doesn't have an algorithmically generated name then use a CmmLabel
- -- instead and give it an appropriate PackageId argument.
+ -- instead and give it an appropriate PackageKey argument.
| RtsLabel
RtsLabelInfo
@@ -237,7 +237,7 @@ data CLabel
data ForeignLabelSource
-- | Label is in a named package
- = ForeignLabelInPackage PackageId
+ = ForeignLabelInPackage PackageKey
-- | Label is in some external, system package that doesn't also
-- contain compiled Haskell code, and is not associated with any .hi files.
@@ -411,27 +411,27 @@ mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
mkArrWords_infoLabel, mkSMAP_FROZEN_infoLabel, mkSMAP_FROZEN0_infoLabel,
mkSMAP_DIRTY_infoLabel :: CLabel
mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
-mkSplitMarkerLabel = CmmLabel rtsPackageId (fsLit "__stg_split_marker") CmmCode
-mkUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_upd_frame") CmmInfo
-mkBHUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_bh_upd_frame" ) CmmInfo
-mkIndStaticInfoLabel = CmmLabel rtsPackageId (fsLit "stg_IND_STATIC") CmmInfo
-mkMainCapabilityLabel = CmmLabel rtsPackageId (fsLit "MainCapability") CmmData
-mkMAP_FROZEN_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo
-mkMAP_FROZEN0_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo
-mkMAP_DIRTY_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
-mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageId (fsLit "stg_EMPTY_MVAR") CmmInfo
-mkTopTickyCtrLabel = CmmLabel rtsPackageId (fsLit "top_ct") CmmData
-mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmInfo
-mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmEntry
-mkArrWords_infoLabel = CmmLabel rtsPackageId (fsLit "stg_ARR_WORDS") CmmInfo
-mkSMAP_FROZEN_infoLabel = CmmLabel rtsPackageId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo
-mkSMAP_FROZEN0_infoLabel = CmmLabel rtsPackageId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo
-mkSMAP_DIRTY_infoLabel = CmmLabel rtsPackageId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkSplitMarkerLabel = CmmLabel rtsPackageKey (fsLit "__stg_split_marker") CmmCode
+mkUpdInfoLabel = CmmLabel rtsPackageKey (fsLit "stg_upd_frame") CmmInfo
+mkBHUpdInfoLabel = CmmLabel rtsPackageKey (fsLit "stg_bh_upd_frame" ) CmmInfo
+mkIndStaticInfoLabel = CmmLabel rtsPackageKey (fsLit "stg_IND_STATIC") CmmInfo
+mkMainCapabilityLabel = CmmLabel rtsPackageKey (fsLit "MainCapability") CmmData
+mkMAP_FROZEN_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo
+mkMAP_FROZEN0_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo
+mkMAP_DIRTY_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_EMPTY_MVAR") CmmInfo
+mkTopTickyCtrLabel = CmmLabel rtsPackageKey (fsLit "top_ct") CmmData
+mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageKey (fsLit "stg_CAF_BLACKHOLE") CmmInfo
+mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageKey (fsLit "stg_CAF_BLACKHOLE") CmmEntry
+mkArrWords_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_ARR_WORDS") CmmInfo
+mkSMAP_FROZEN_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo
+mkSMAP_FROZEN0_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo
+mkSMAP_DIRTY_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
-----
mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel
- :: PackageId -> FastString -> CLabel
+ :: PackageKey -> FastString -> CLabel
mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo
mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry
@@ -639,7 +639,7 @@ needsCDecl (RtsLabel _) = False
needsCDecl (CmmLabel pkgId _ _)
-- Prototypes for labels defined in the runtime system are imported
-- into HC files via includes/Stg.h.
- | pkgId == rtsPackageId = False
+ | pkgId == rtsPackageKey = False
-- For other labels we inline one into the HC file directly.
| otherwise = True
@@ -849,11 +849,11 @@ idInfoLabelType info =
-- @labelDynamic@ returns @True@ if the label is located
-- in a DLL, be it a data reference or not.
-labelDynamic :: DynFlags -> PackageId -> Module -> CLabel -> Bool
+labelDynamic :: DynFlags -> PackageKey -> Module -> CLabel -> Bool
labelDynamic dflags this_pkg this_mod lbl =
case lbl of
-- is the RTS in a DLL or not?
- RtsLabel _ -> not (gopt Opt_Static dflags) && (this_pkg /= rtsPackageId)
+ RtsLabel _ -> not (gopt Opt_Static dflags) && (this_pkg /= rtsPackageKey)
IdLabel n _ _ -> isDllName dflags this_pkg this_mod n
@@ -886,7 +886,9 @@ labelDynamic dflags this_pkg this_mod lbl =
-- libraries
True
- PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageId m)
+ PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageKey m)
+
+ HpcTicksLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageKey m)
-- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
_ -> False
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index e21efc13af..9e9bae93c6 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -80,10 +80,7 @@ data GenCmmDecl d h g
-- registers will be correct in generated C-- code, but
-- not in hand-written C-- code. However,
-- splitAtProcPoints calculates correct liveness
- -- information for CmmProc's. Right now only the LLVM
- -- back-end relies on correct liveness information and
- -- for that back-end we always call splitAtProcPoints, so
- -- all is good.
+ -- information for CmmProcs.
g -- Control-flow graph for the procedure's code
| CmmData -- Static data
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index e10716a2ac..6521a84006 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -286,7 +286,7 @@ bundle :: Map CLabel CAFSet
-> (CAFEnv, CmmDecl)
-> (CAFSet, Maybe CLabel)
-> (BlockEnv CAFSet, CmmDecl)
-bundle flatmap (env, decl@(CmmProc infos lbl _ g)) (closure_cafs, mb_lbl)
+bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl)
= ( mapMapWithKey get_cafs (info_tbls infos), decl )
where
entry = g_entry g
@@ -297,9 +297,13 @@ bundle flatmap (env, decl@(CmmProc infos lbl _ g)) (closure_cafs, mb_lbl)
get_cafs l _
| l == entry = entry_cafs
- | otherwise = if not (mapMember l env)
- then pprPanic "bundle" (ppr l <+> ppr lbl <+> ppr (info_tbls infos) $$ ppr env $$ ppr decl)
- else flatten flatmap $ expectJust "bundle" $ mapLookup l env
+ | Just info <- mapLookup l env = flatten flatmap info
+ | otherwise = Set.empty
+ -- the label might not be in the env if the code corresponding to
+ -- this info table was optimised away (perhaps because it was
+ -- unreachable). In this case it doesn't matter what SRT we
+ -- infer, since the info table will not appear in the generated
+ -- code. See #9329.
bundle _flatmap (_, decl) _
= ( mapEmpty, decl )
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index aae3ea1c71..3bfc728ac0 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -1,11 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module CmmInfo (
mkEmptyContInfoTable,
cmmToRawCmm,
@@ -62,7 +55,7 @@ import Data.Word
-- When we split at proc points, we need an empty info table.
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
-mkEmptyContInfoTable info_lbl
+mkEmptyContInfoTable info_lbl
= CmmInfoTable { cit_lbl = info_lbl
, cit_rep = mkStackRep []
, cit_prof = NoProfilingInfo
@@ -84,31 +77,31 @@ cmmToRawCmm dflags cmms
-- represented by a label+offset expression).
--
-- With tablesNextToCode, the layout is
--- <reversed variable part>
--- <normal forward StgInfoTable, but without
--- an entry point at the front>
--- <code>
+-- <reversed variable part>
+-- <normal forward StgInfoTable, but without
+-- an entry point at the front>
+-- <code>
--
-- Without tablesNextToCode, the layout of an info table is
--- <entry label>
--- <normal forward rest of StgInfoTable>
--- <forward variable part>
+-- <entry label>
+-- <normal forward rest of StgInfoTable>
+-- <forward variable part>
--
--- See includes/rts/storage/InfoTables.h
+-- See includes/rts/storage/InfoTables.h
--
-- For return-points these are as follows
--
-- Tables next to code:
--
--- <srt slot>
--- <standard info table>
--- ret-addr --> <entry code (if any)>
+-- <srt slot>
+-- <standard info table>
+-- ret-addr --> <entry code (if any)>
--
-- Not tables-next-to-code:
--
--- ret-addr --> <ptr to entry code>
--- <standard info table>
--- <srt slot>
+-- ret-addr --> <ptr to entry code>
+-- <standard info table>
+-- <srt slot>
--
-- * The SRT slot is only there if there is SRT info to record
@@ -168,21 +161,21 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
reverse rel_extra_bits ++ rel_std_info))
-----------------------------------------------------
-type InfoTableContents = ( [CmmLit] -- The standard part
- , [CmmLit] ) -- The "extra bits"
+type InfoTableContents = ( [CmmLit] -- The standard part
+ , [CmmLit] ) -- The "extra bits"
-- These Lits have *not* had mkRelativeTo applied to them
mkInfoTableContents :: DynFlags
-> CmmInfoTable
-> Maybe Int -- Override default RTS type tag?
-> UniqSM ([RawCmmDecl], -- Auxiliary top decls
- InfoTableContents) -- Info tbl + extra bits
+ InfoTableContents) -- Info tbl + extra bits
mkInfoTableContents dflags
info@(CmmInfoTable { cit_lbl = info_lbl
, cit_rep = smrep
, cit_prof = prof
- , cit_srt = srt })
+ , cit_srt = srt })
mb_rts_tag
| RTSRep rts_tag rep <- smrep
= mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)
@@ -216,9 +209,9 @@ mkInfoTableContents dflags
where
mk_pieces :: ClosureTypeInfo -> [CmmLit]
-> UniqSM ( Maybe StgHalfWord -- Override the SRT field with this
- , Maybe CmmLit -- Override the layout field with this
- , [CmmLit] -- "Extra bits" for info table
- , [RawCmmDecl]) -- Auxiliary data decls
+ , Maybe CmmLit -- Override the layout field with this
+ , [CmmLit] -- "Extra bits" for info table
+ , [RawCmmDecl]) -- Auxiliary data decls
mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor
= do { (descr_lit, decl) <- newStringLit con_descr
; return ( Just (toStgHalfWord dflags (fromIntegral con_tag))
@@ -231,7 +224,7 @@ mkInfoTableContents dflags
= return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], [])
-- Layout known (one free var); we use the layout field for offset
- mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
+ mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
= do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label
; return (Nothing, Nothing, extra_bits, []) }
@@ -281,7 +274,7 @@ mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)
-------------------------------------------------------------------------
--
--- Position independent code
+-- Position independent code
--
-------------------------------------------------------------------------
-- In order to support position independent code, we mustn't put absolute
@@ -293,7 +286,7 @@ mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)
-- as we want to keep binary compatibility between PIC and non-PIC.
makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
-
+
makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
| tablesNextToCode dflags
= CmmLabelDiffOff lbl info_lbl 0
@@ -305,16 +298,16 @@ makeRelativeRefTo _ _ lit = lit
-------------------------------------------------------------------------
--
--- Build a liveness mask for the stack layout
+-- Build a liveness mask for the stack layout
--
-------------------------------------------------------------------------
-- There are four kinds of things on the stack:
--
--- - pointer variables (bound in the environment)
--- - non-pointer variables (bound in the environment)
--- - free slots (recorded in the stack free list)
--- - non-pointer data slots (recorded in the stack free list)
+-- - pointer variables (bound in the environment)
+-- - non-pointer variables (bound in the environment)
+-- - free slots (recorded in the stack free list)
+-- - non-pointer data slots (recorded in the stack free list)
--
-- The first two are represented with a 'Just' of a 'LocalReg'.
-- The last two with one or more 'Nothing' constructors.
@@ -332,7 +325,7 @@ mkLivenessBits dflags liveness
| n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word
= do { uniq <- getUniqueUs
; let bitmap_lbl = mkBitmapLabel uniq
- ; return (CmmLabel bitmap_lbl,
+ ; return (CmmLabel bitmap_lbl,
[mkRODataLits bitmap_lbl lits]) }
| otherwise -- Fits in one word
@@ -343,10 +336,10 @@ mkLivenessBits dflags liveness
bitmap :: Bitmap
bitmap = mkBitmap dflags liveness
- small_bitmap = case bitmap of
+ small_bitmap = case bitmap of
[] -> toStgWord dflags 0
[b] -> b
- _ -> panic "mkLiveness"
+ _ -> panic "mkLiveness"
bitmap_word = toStgWord dflags (fromIntegral n_bits)
.|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
@@ -357,7 +350,7 @@ mkLivenessBits dflags liveness
-------------------------------------------------------------------------
--
--- Generating a standard info table
+-- Generating a standard info table
--
-------------------------------------------------------------------------
@@ -370,23 +363,23 @@ mkLivenessBits dflags liveness
mkStdInfoTable
:: DynFlags
- -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling)
+ -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling)
-> Int -- Closure RTS tag
-> StgHalfWord -- SRT length
- -> CmmLit -- layout field
+ -> CmmLit -- layout field
-> [CmmLit]
mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
- = -- Parallel revertible-black hole field
+ = -- Parallel revertible-black hole field
prof_info
- -- Ticky info (none at present)
- -- Debug info (none at present)
+ -- Ticky info (none at present)
+ -- Debug info (none at present)
++ [layout_lit, type_lit]
- where
- prof_info
- | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
- | otherwise = []
+ where
+ prof_info
+ | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
+ | otherwise = []
type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len
@@ -417,7 +410,7 @@ srtEscape dflags = toStgHalfWord dflags (-1)
-------------------------------------------------------------------------
--
--- Accessing fields of an info table
+-- Accessing fields of an info table
--
-------------------------------------------------------------------------
@@ -492,7 +485,7 @@ funInfoTable dflags info_ptr
= cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
| otherwise
= cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
- -- Past the entry code pointer
+ -- Past the entry code pointer
-- Takes the info pointer of a function, returns the function's arity
funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
@@ -515,7 +508,7 @@ funInfoArity dflags iptr
-- Info table sizes & offsets
--
-----------------------------------------------------------------------------
-
+
stdInfoTableSizeW :: DynFlags -> WordOff
-- The size of a standard info table varies with profiling/ticky etc,
-- so we can't get it from Constants
@@ -547,15 +540,14 @@ stdInfoTableSizeB :: DynFlags -> ByteOff
stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
stdSrtBitmapOffset :: DynFlags -> ByteOff
--- Byte offset of the SRT bitmap half-word which is
+-- Byte offset of the SRT bitmap half-word which is
-- in the *higher-addressed* part of the type_lit
stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags
stdClosureTypeOffset :: DynFlags -> ByteOff
--- Byte offset of the closure type half-word
+-- Byte offset of the closure type half-word
stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
-
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index db22deb639..c582b783f2 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -870,7 +870,7 @@ areaToSp _ _ _ _ other = other
-- really the job of the stack layout algorithm, hence we do it now.
optStackCheck :: CmmNode O C -> CmmNode O C
-optStackCheck n = -- Note [null stack check]
+optStackCheck n = -- Note [Always false stack check]
case n of
CmmCondBranch (CmmLit (CmmInt 0 _)) _true false -> CmmBranch false
other -> other
diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x
index bb5b4e3ae5..f56db7bd4c 100644
--- a/compiler/cmm/CmmLex.x
+++ b/compiler/cmm/CmmLex.x
@@ -44,7 +44,7 @@ $white_no_nl = $whitechar # \n
$ascdigit = 0-9
$unidigit = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
$digit = [$ascdigit $unidigit]
-$octit = 0-7
+$octit = 0-7
$hexit = [$digit A-F a-f]
$unilarge = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
@@ -70,56 +70,56 @@ $namechar = [$namebegin $digit]
cmm :-
-$white_no_nl+ ;
+$white_no_nl+ ;
^\# pragma .* \n ; -- Apple GCC 3.3 CPP generates pragmas in its output
-^\# (line)? { begin line_prag }
+^\# (line)? { begin line_prag }
-- single-line line pragmas, of the form
-- # <line> "<file>" <extra-stuff> \n
-<line_prag> $digit+ { setLine line_prag1 }
-<line_prag1> \" [^\"]* \" { setFile line_prag2 }
-<line_prag2> .* { pop }
+<line_prag> $digit+ { setLine line_prag1 }
+<line_prag1> \" [^\"]* \" { setFile line_prag2 }
+<line_prag2> .* { pop }
<0> {
- \n ;
-
- [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char }
-
- ".." { kw CmmT_DotDot }
- "::" { kw CmmT_DoubleColon }
- ">>" { kw CmmT_Shr }
- "<<" { kw CmmT_Shl }
- ">=" { kw CmmT_Ge }
- "<=" { kw CmmT_Le }
- "==" { kw CmmT_Eq }
- "!=" { kw CmmT_Ne }
- "&&" { kw CmmT_BoolAnd }
- "||" { kw CmmT_BoolOr }
-
- P@decimal { global_regN (\n -> VanillaReg n VGcPtr) }
- R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) }
- F@decimal { global_regN FloatReg }
- D@decimal { global_regN DoubleReg }
- L@decimal { global_regN LongReg }
- Sp { global_reg Sp }
- SpLim { global_reg SpLim }
- Hp { global_reg Hp }
- HpLim { global_reg HpLim }
+ \n ;
+
+ [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char }
+
+ ".." { kw CmmT_DotDot }
+ "::" { kw CmmT_DoubleColon }
+ ">>" { kw CmmT_Shr }
+ "<<" { kw CmmT_Shl }
+ ">=" { kw CmmT_Ge }
+ "<=" { kw CmmT_Le }
+ "==" { kw CmmT_Eq }
+ "!=" { kw CmmT_Ne }
+ "&&" { kw CmmT_BoolAnd }
+ "||" { kw CmmT_BoolOr }
+
+ P@decimal { global_regN (\n -> VanillaReg n VGcPtr) }
+ R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) }
+ F@decimal { global_regN FloatReg }
+ D@decimal { global_regN DoubleReg }
+ L@decimal { global_regN LongReg }
+ Sp { global_reg Sp }
+ SpLim { global_reg SpLim }
+ Hp { global_reg Hp }
+ HpLim { global_reg HpLim }
CCCS { global_reg CCCS }
CurrentTSO { global_reg CurrentTSO }
CurrentNursery { global_reg CurrentNursery }
- HpAlloc { global_reg HpAlloc }
- BaseReg { global_reg BaseReg }
-
- $namebegin $namechar* { name }
-
- 0 @octal { tok_octal }
- @decimal { tok_decimal }
- 0[xX] @hexadecimal { tok_hexadecimal }
- @floating_point { strtoken tok_float }
-
- \" @strchar* \" { strtoken tok_string }
+ HpAlloc { global_reg HpAlloc }
+ BaseReg { global_reg BaseReg }
+
+ $namebegin $namechar* { name }
+
+ 0 @octal { tok_octal }
+ @decimal { tok_decimal }
+ 0[xX] @hexadecimal { tok_hexadecimal }
+ @floating_point { strtoken tok_float }
+
+ \" @strchar* \" { strtoken tok_string }
}
{
@@ -171,9 +171,9 @@ data CmmToken
| CmmT_float64
| CmmT_gcptr
| CmmT_GlobalReg GlobalReg
- | CmmT_Name FastString
- | CmmT_String String
- | CmmT_Int Integer
+ | CmmT_Name FastString
+ | CmmT_String String
+ | CmmT_Int Integer
| CmmT_Float Rational
| CmmT_EOF
deriving (Show)
@@ -196,88 +196,88 @@ kw :: CmmToken -> Action
kw tok span buf len = return (L span tok)
global_regN :: (Int -> GlobalReg) -> Action
-global_regN con span buf len
+global_regN con span buf len
= return (L span (CmmT_GlobalReg (con (fromIntegral n))))
where buf' = stepOn buf
- n = parseUnsignedInteger buf' (len-1) 10 octDecDigit
+ n = parseUnsignedInteger buf' (len-1) 10 octDecDigit
global_reg :: GlobalReg -> Action
global_reg r span buf len = return (L span (CmmT_GlobalReg r))
strtoken :: (String -> CmmToken) -> Action
-strtoken f span buf len =
+strtoken f span buf len =
return (L span $! (f $! lexemeToString buf len))
name :: Action
-name span buf len =
+name span buf len =
case lookupUFM reservedWordsFM fs of
- Just tok -> return (L span tok)
- Nothing -> return (L span (CmmT_Name fs))
+ Just tok -> return (L span tok)
+ Nothing -> return (L span (CmmT_Name fs))
where
- fs = lexemeToFastString buf len
+ fs = lexemeToFastString buf len
reservedWordsFM = listToUFM $
- map (\(x, y) -> (mkFastString x, y)) [
- ( "CLOSURE", CmmT_CLOSURE ),
- ( "INFO_TABLE", CmmT_INFO_TABLE ),
- ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ),
- ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ),
- ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ),
- ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),
- ( "else", CmmT_else ),
- ( "export", CmmT_export ),
- ( "section", CmmT_section ),
- ( "align", CmmT_align ),
- ( "goto", CmmT_goto ),
- ( "if", CmmT_if ),
+ map (\(x, y) -> (mkFastString x, y)) [
+ ( "CLOSURE", CmmT_CLOSURE ),
+ ( "INFO_TABLE", CmmT_INFO_TABLE ),
+ ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ),
+ ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ),
+ ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ),
+ ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),
+ ( "else", CmmT_else ),
+ ( "export", CmmT_export ),
+ ( "section", CmmT_section ),
+ ( "align", CmmT_align ),
+ ( "goto", CmmT_goto ),
+ ( "if", CmmT_if ),
( "call", CmmT_call ),
( "jump", CmmT_jump ),
( "foreign", CmmT_foreign ),
- ( "never", CmmT_never ),
- ( "prim", CmmT_prim ),
+ ( "never", CmmT_never ),
+ ( "prim", CmmT_prim ),
( "reserve", CmmT_reserve ),
( "return", CmmT_return ),
- ( "returns", CmmT_returns ),
- ( "import", CmmT_import ),
- ( "switch", CmmT_switch ),
- ( "case", CmmT_case ),
+ ( "returns", CmmT_returns ),
+ ( "import", CmmT_import ),
+ ( "switch", CmmT_switch ),
+ ( "case", CmmT_case ),
( "default", CmmT_default ),
( "push", CmmT_push ),
( "bits8", CmmT_bits8 ),
- ( "bits16", CmmT_bits16 ),
- ( "bits32", CmmT_bits32 ),
- ( "bits64", CmmT_bits64 ),
- ( "bits128", CmmT_bits128 ),
- ( "bits256", CmmT_bits256 ),
- ( "bits512", CmmT_bits512 ),
- ( "float32", CmmT_float32 ),
- ( "float64", CmmT_float64 ),
+ ( "bits16", CmmT_bits16 ),
+ ( "bits32", CmmT_bits32 ),
+ ( "bits64", CmmT_bits64 ),
+ ( "bits128", CmmT_bits128 ),
+ ( "bits256", CmmT_bits256 ),
+ ( "bits512", CmmT_bits512 ),
+ ( "float32", CmmT_float32 ),
+ ( "float64", CmmT_float64 ),
-- New forms
- ( "b8", CmmT_bits8 ),
- ( "b16", CmmT_bits16 ),
- ( "b32", CmmT_bits32 ),
- ( "b64", CmmT_bits64 ),
- ( "b128", CmmT_bits128 ),
- ( "b256", CmmT_bits256 ),
- ( "b512", CmmT_bits512 ),
- ( "f32", CmmT_float32 ),
- ( "f64", CmmT_float64 ),
- ( "gcptr", CmmT_gcptr )
- ]
-
-tok_decimal span buf len
+ ( "b8", CmmT_bits8 ),
+ ( "b16", CmmT_bits16 ),
+ ( "b32", CmmT_bits32 ),
+ ( "b64", CmmT_bits64 ),
+ ( "b128", CmmT_bits128 ),
+ ( "b256", CmmT_bits256 ),
+ ( "b512", CmmT_bits512 ),
+ ( "f32", CmmT_float32 ),
+ ( "f64", CmmT_float64 ),
+ ( "gcptr", CmmT_gcptr )
+ ]
+
+tok_decimal span buf len
= return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit))
-tok_octal span buf len
+tok_octal span buf len
= return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))
-tok_hexadecimal span buf len
+tok_hexadecimal span buf len
= return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
tok_float str = CmmT_Float $! readRational str
tok_string str = CmmT_String (read str)
- -- urk, not quite right, but it'll do for now
+ -- urk, not quite right, but it'll do for now
-- -----------------------------------------------------------------------------
-- Line pragmas
@@ -286,7 +286,7 @@ setLine :: Int -> Action
setLine code span buf len = do
let line = parseUnsignedInteger buf len 10 octDecDigit
setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
- -- subtract one: the line number refers to the *following* line
+ -- subtract one: the line number refers to the *following* line
-- trace ("setLine " ++ show line) $ do
popLexState
pushLexState code
@@ -316,17 +316,17 @@ lexToken = do
sc <- getLexState
case alexScan inp sc of
AlexEOF -> do let span = mkRealSrcSpan loc1 loc1
- setLastToken span 0
- return (L span CmmT_EOF)
+ setLastToken span 0
+ return (L span CmmT_EOF)
AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
AlexSkip inp2 _ -> do
- setInput inp2
- lexToken
+ setInput inp2
+ lexToken
AlexToken inp2@(end,buf2) len t -> do
- setInput inp2
- let span = mkRealSrcSpan loc1 end
- span `seq` setLastToken span len
- t span buf len
+ setInput inp2
+ let span = mkRealSrcSpan loc1 end
+ span `seq` setLastToken span len
+ t span buf len
-- -----------------------------------------------------------------------------
-- Monad stuff
@@ -351,7 +351,7 @@ alexGetByte (loc,s)
where c = currentChar s
b = fromIntegral $ ord $ c
loc' = advanceSrcLoc loc c
- s' = stepOn s
+ s' = stepOn s
getInput :: P AlexInput
getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b)
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index c4ec393ad6..d8ce492de1 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -19,6 +19,9 @@ module CmmMachOp
-- CallishMachOp
, CallishMachOp(..), callishMachOpHints
, pprCallishMachOp
+
+ -- Atomic read-modify-write
+ , AtomicMachOp(..)
)
where
@@ -547,8 +550,24 @@ data CallishMachOp
| MO_PopCnt Width
| MO_BSwap Width
+
+ -- Atomic read-modify-write.
+ | MO_AtomicRMW Width AtomicMachOp
+ | MO_AtomicRead Width
+ | MO_AtomicWrite Width
+ | MO_Cmpxchg Width
deriving (Eq, Show)
+-- | The operation to perform atomically.
+data AtomicMachOp =
+ AMO_Add
+ | AMO_Sub
+ | AMO_And
+ | AMO_Nand
+ | AMO_Or
+ | AMO_Xor
+ deriving (Eq, Show)
+
pprCallishMachOp :: CallishMachOp -> SDoc
pprCallishMachOp mo = text (show mo)
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 49143170c3..803333001c 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -573,7 +573,7 @@ importName
-- A label imported with an explicit packageId.
| STRING NAME
- { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }
+ { ($2, mkCmmCodeLabel (fsToPackageKey (mkFastString $1)) $2) }
names :: { [FastString] }
@@ -1101,7 +1101,7 @@ profilingInfo dflags desc_str ty_str
else ProfilingInfo (stringToWord8s desc_str)
(stringToWord8s ty_str)
-staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
+staticClosure :: PackageKey -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
= do dflags <- getDynFlags
let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 4314695201..af4f62a4a8 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -326,10 +326,9 @@ _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.
{- Note [unreachable blocks]
The control-flow optimiser sometimes leaves unreachable blocks behind
-containing junk code. If these blocks make it into the native code
-generator then they trigger a register allocator panic because they
-refer to undefined LocalRegs, so we must eliminate any unreachable
-blocks before passing the code onwards.
+containing junk code. These aren't necessarily a problem, but
+removing them is good because it might save time in the native code
+generator later.
-}
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index 4c025425ab..4dced9afd2 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -650,6 +650,10 @@ data AbsMem
-- perhaps we ought to have a special annotation for calls that can
-- modify heap/stack memory. For now we just use the conservative
-- definition here.
+--
+-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and
+-- therefore we should never float any memory operations across one of
+-- these calls.
bothMems :: AbsMem -> AbsMem -> AbsMem
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 47b247e278..455c79ba02 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -753,6 +753,10 @@ pprCallishMachOp_for_C mop
MO_Memmove -> ptext (sLit "memmove")
(MO_BSwap w) -> ptext (sLit $ bSwapLabel w)
(MO_PopCnt w) -> ptext (sLit $ popCntLabel w)
+ (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)
+ (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w)
+ (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w)
+ (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)
(MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w)
MO_S_QuotRem {} -> unsupported
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index b5beb07ae9..cc3124028a 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -138,6 +138,9 @@ pprCmmGraph g
$$ nest 2 (vcat $ map ppr blocks)
$$ text "}"
where blocks = postorderDfs g
+ -- postorderDfs has the side-effect of discarding unreachable code,
+ -- so pretty-printed Cmm will omit any unreachable blocks. This can
+ -- sometimes be confusing.
---------------------------------------------
-- Outputting CmmNode and types which it contains
View Lorry Controller Status