[Git][ghc/ghc][master] 4 commits: Cmm: introduce SAVE_REGS/RESTORE_REGS
Marge Bot
gitlab at gitlab.haskell.org
Wed Jun 24 02:48:28 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7750bd45 by Sylvain Henry at 2020-06-23T22:48:18-04:00
Cmm: introduce SAVE_REGS/RESTORE_REGS
We don't want to save both Fn and Dn register sets on x86-64 as they are
aliased to the same arch register (XMMn).
Moreover, when SAVE_STGREGS was used in conjunction with `jump foo [*]`
which makes a set of Cmm registers alive so that they cover all arch
registers used to pass parameter, we could have Fn, Dn and XMMn alive at
the same time. It made the LLVM code generator choke (see #17920).
Now `SAVE_REGS/RESTORE_REGS` and `jump foo [*]` use the same set of
registers.
- - - - -
2636794d by Sylvain Henry at 2020-06-23T22:48:18-04:00
CmmToC: don't add extern decl to parsed Cmm data
Previously, if a .cmm file *not in the RTS* contained something like:
```cmm
section "rodata" { msg : bits8[] "Test\n"; }
```
It would get compiled by CmmToC into:
```c
ERW_(msg);
const char msg[] = "Test\012";
```
and fail with:
```
/tmp/ghc32129_0/ghc_4.hc:5:12: error:
error: conflicting types for \u2018msg\u2019
const char msg[] = "Test\012";
^~~
In file included from /tmp/ghc32129_0/ghc_4.hc:3:0: error:
/tmp/ghc32129_0/ghc_4.hc:4:6: error:
note: previous declaration of \u2018msg\u2019 was here
ERW_(msg);
^
/builds/hsyl20/ghc/_build/install/lib/ghc-8.11.0.20200605/lib/../lib/x86_64-linux-ghc-8.11.0.20200605/rts-1.0/include/Stg.h:253:46: error:
note: in definition of macro \u2018ERW_\u2019
#define ERW_(X) extern StgWordArray (X)
^
```
See the rationale for this on https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/backends/ppr-c#prototypes
Now we don't generate these extern declarations (ERW_, etc.) for
top-level data. It shouldn't change anything for the RTS (the only place
we use .cmm files) as it is already special cased in
`GHC.Cmm.CLabel.needsCDecl`. And hand-written Cmm can use explicit
extern declarations when needed.
Note that it allows `cgrun069` test to pass with CmmToC (cf #15467).
- - - - -
5f6a0665 by Sylvain Henry at 2020-06-23T22:48:18-04:00
LLVM: refactor and comment register padding code (#17920)
- - - - -
cad62ef1 by Sylvain Henry at 2020-06-23T22:48:18-04:00
Add tests for #17920
Metric Decrease:
T12150
T12234
- - - - -
21 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/CallConv.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/StgToCmm/Foreign.hs
- compiler/GHC/StgToCmm/Prof.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/StgToCmm/Utils.hs
- includes/Cmm.h
- rts/StgMiscClosures.cmm
- testsuite/driver/testlib.py
- testsuite/tests/cmm/should_compile/all.T
- testsuite/tests/codeGen/should_compile/all.T
- testsuite/tests/codeGen/should_fail/all.T
- + testsuite/tests/codeGen/should_run/T17920.cmm
- + testsuite/tests/codeGen/should_run/T17920.stdout
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/driver/all.T
- + testsuite/tests/llvm/should_compile/T17920fail.cmm
- testsuite/tests/llvm/should_compile/all.T
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -12,6 +12,7 @@
module GHC.Cmm.CLabel (
CLabel, -- abstract type
+ NeedExternDecl (..),
ForeignLabelSource(..),
pprDebugCLabel,
@@ -71,6 +72,7 @@ module GHC.Cmm.CLabel (
mkCmmRetLabel,
mkCmmCodeLabel,
mkCmmDataLabel,
+ mkRtsCmmDataLabel,
mkCmmClosureLabel,
mkRtsApFastLabel,
@@ -182,13 +184,14 @@ data CLabel
IdLabel
Name
CafInfo
- IdLabelInfo -- encodes the suffix of the label
+ IdLabelInfo -- ^ encodes the suffix of the label
-- | A label from a .cmm file that is not associated with a .hs level Id.
| CmmLabel
- UnitId -- what package the label belongs to.
- FastString -- identifier giving the prefix of the label
- CmmLabelInfo -- encodes the suffix of the label
+ UnitId -- ^ what package the label belongs to.
+ NeedExternDecl -- ^ does the label need an "extern .." declaration
+ 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
@@ -208,13 +211,13 @@ data CLabel
-- | A 'C' (or otherwise foreign) label.
--
| ForeignLabel
- FastString -- name of the imported label.
+ FastString -- ^ name of the imported label.
- (Maybe Int) -- possible '@n' suffix for stdcall functions
+ (Maybe Int) -- ^ possible '@n' suffix for stdcall functions
-- When generating C, the '@n' suffix is omitted, but when
-- generating assembler we must add it to the label.
- ForeignLabelSource -- what package the foreign label is in.
+ ForeignLabelSource -- ^ what package the foreign label is in.
FunctionOrData
@@ -227,7 +230,7 @@ data CLabel
-- Must not occur outside of the NCG or LLVM code generators.
| AsmTempDerivedLabel
CLabel
- FastString -- suffix
+ FastString -- ^ suffix
| StringLitLabel
{-# UNPACK #-} !Unique
@@ -275,6 +278,24 @@ isTickyLabel :: CLabel -> Bool
isTickyLabel (IdLabel _ _ RednCounts) = True
isTickyLabel _ = False
+-- | Indicate if "GHC.CmmToC" has to generate an extern declaration for the
+-- label (e.g. "extern StgWordArray(foo)"). The type is fixed to StgWordArray.
+--
+-- Symbols from the RTS don't need "extern" declarations because they are
+-- exposed via "includes/Stg.h" with the appropriate type. See 'needsCDecl'.
+--
+-- The fixed StgWordArray type led to "conflicting types" issues with user
+-- provided Cmm files (not in the RTS) that declare data of another type (#15467
+-- and test for #17920). Hence the Cmm parser considers that labels in data
+-- sections don't need the "extern" declaration (just add one explicitly if you
+-- need it).
+--
+-- See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/backends/ppr-c#prototypes
+-- for why extern declaration are needed at all.
+newtype NeedExternDecl
+ = NeedExternDecl Bool
+ deriving (Ord,Eq)
+
-- This is laborious, but necessary. We can't derive Ord because
-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
-- implementation. See Note [No Ord for Unique]
@@ -285,10 +306,11 @@ instance Ord CLabel where
compare a1 a2 `thenCmp`
compare b1 b2 `thenCmp`
compare c1 c2
- compare (CmmLabel a1 b1 c1) (CmmLabel a2 b2 c2) =
+ compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) =
compare a1 a2 `thenCmp`
compare b1 b2 `thenCmp`
- compare c1 c2
+ compare c1 c2 `thenCmp`
+ compare d1 d2
compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2
compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2
compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =
@@ -380,7 +402,7 @@ pprDebugCLabel lbl
= case lbl of
IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel"
<> whenPprDebug (text ":" <> text (show info)))
- CmmLabel pkg _name _info
+ CmmLabel pkg _ext _name _info
-> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel")
@@ -510,24 +532,24 @@ mkDirty_MUT_VAR_Label,
mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel
mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
mkNonmovingWriteBarrierEnabledLabel
- = CmmLabel rtsUnitId (fsLit "nonmoving_write_barrier_enabled") CmmData
-mkUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_upd_frame") CmmInfo
-mkBHUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" ) CmmInfo
-mkIndStaticInfoLabel = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC") CmmInfo
-mkMainCapabilityLabel = CmmLabel rtsUnitId (fsLit "MainCapability") CmmData
-mkMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
-mkMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
-mkMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
-mkTopTickyCtrLabel = CmmLabel rtsUnitId (fsLit "top_ct") CmmData
-mkCAFBlackHoleInfoTableLabel = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE") CmmInfo
-mkArrWords_infoLabel = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS") CmmInfo
-mkSMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
-mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
-mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
-mkBadAlignmentLabel = CmmLabel rtsUnitId (fsLit "stg_badAlignment") CmmEntry
+ = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData
+mkUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame") CmmInfo
+mkBHUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" ) CmmInfo
+mkIndStaticInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC") CmmInfo
+mkMainCapabilityLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "MainCapability") CmmData
+mkMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
+mkMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
+mkMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkTopTickyCtrLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "top_ct") CmmData
+mkCAFBlackHoleInfoTableLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_CAF_BLACKHOLE") CmmInfo
+mkArrWords_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_ARR_WORDS") CmmInfo
+mkSMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
+mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
+mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkBadAlignmentLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment") CmmEntry
mkSRTInfoLabel :: Int -> CLabel
-mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
+mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo
where
lbl =
case n of
@@ -551,16 +573,23 @@ mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
-----
mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
- mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel
+ mkCmmCodeLabel, mkCmmClosureLabel
:: UnitId -> FastString -> CLabel
-mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo
-mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry
-mkCmmRetInfoLabel pkg str = CmmLabel pkg str CmmRetInfo
-mkCmmRetLabel pkg str = CmmLabel pkg str CmmRet
-mkCmmCodeLabel pkg str = CmmLabel pkg str CmmCode
-mkCmmDataLabel pkg str = CmmLabel pkg str CmmData
-mkCmmClosureLabel pkg str = CmmLabel pkg str CmmClosure
+mkCmmDataLabel :: UnitId -> NeedExternDecl -> FastString -> CLabel
+mkRtsCmmDataLabel :: FastString -> CLabel
+
+mkCmmInfoLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmInfo
+mkCmmEntryLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmEntry
+mkCmmRetInfoLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmRetInfo
+mkCmmRetLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmRet
+mkCmmCodeLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmCode
+mkCmmClosureLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmClosure
+mkCmmDataLabel pkg ext str = CmmLabel pkg ext str CmmData
+mkRtsCmmDataLabel str = CmmLabel rtsUnitId (NeedExternDecl False) str CmmData
+ -- RTS symbols don't need "GHC.CmmToC" to
+ -- generate \"extern\" declaration (they are
+ -- exposed via includes/Stg.h)
mkLocalBlockLabel :: Unique -> CLabel
mkLocalBlockLabel u = LocalBlockLabel u
@@ -593,7 +622,7 @@ mkApEntryLabel dflags upd arity =
-- A call to some primitive hand written Cmm code
mkPrimCallLabel :: PrimCall -> CLabel
mkPrimCallLabel (PrimCall str pkg)
- = CmmLabel (toUnitId pkg) str CmmPrimCall
+ = CmmLabel (toUnitId pkg) (NeedExternDecl True) str CmmPrimCall
-- Constructing ForeignLabels
@@ -631,7 +660,7 @@ isStaticClosureLabel :: CLabel -> Bool
-- Closure defined in haskell (.hs)
isStaticClosureLabel (IdLabel _ _ Closure) = True
-- Closure defined in cmm
-isStaticClosureLabel (CmmLabel _ _ CmmClosure) = True
+isStaticClosureLabel (CmmLabel _ _ _ CmmClosure) = True
isStaticClosureLabel _lbl = False
-- | Whether label is a .rodata label
@@ -643,7 +672,7 @@ isSomeRODataLabel (IdLabel _ _ InfoTable) = True
isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True
isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True
-- info table defined in cmm (.cmm)
-isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True
+isSomeRODataLabel (CmmLabel _ _ _ CmmInfo) = True
isSomeRODataLabel _lbl = False
-- | Whether label is points to some kind of info table
@@ -725,7 +754,7 @@ mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")
toClosureLbl :: CLabel -> CLabel
toClosureLbl (IdLabel n c _) = IdLabel n c Closure
-toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure
+toClosureLbl (CmmLabel m ext str _) = CmmLabel m ext str CmmClosure
toClosureLbl l = pprPanic "toClosureLbl" (ppr l)
toSlowEntryLbl :: CLabel -> CLabel
@@ -740,16 +769,16 @@ toEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry
toEntryLbl (IdLabel n _ BlockInfoTable) = mkLocalBlockLabel (nameUnique n)
-- See Note [Proc-point local block entry-point].
toEntryLbl (IdLabel n c _) = IdLabel n c Entry
-toEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry
-toEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet
+toEntryLbl (CmmLabel m ext str CmmInfo) = CmmLabel m ext str CmmEntry
+toEntryLbl (CmmLabel m ext str CmmRetInfo) = CmmLabel m ext str CmmRet
toEntryLbl l = pprPanic "toEntryLbl" (ppr l)
toInfoLbl :: CLabel -> CLabel
toInfoLbl (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable
toInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable
toInfoLbl (IdLabel n c _) = IdLabel n c InfoTable
-toInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo
-toInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo
+toInfoLbl (CmmLabel m ext str CmmEntry)= CmmLabel m ext str CmmInfo
+toInfoLbl (CmmLabel m ext str CmmRet) = CmmLabel m ext str CmmRetInfo
toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l)
hasHaskellName :: CLabel -> Maybe Name
@@ -801,10 +830,13 @@ needsCDecl (AsmTempLabel _) = False
needsCDecl (AsmTempDerivedLabel _ _) = False
needsCDecl (RtsLabel _) = False
-needsCDecl (CmmLabel pkgId _ _)
+needsCDecl (CmmLabel pkgId (NeedExternDecl external) _ _)
+ -- local labels mustn't have it
+ | not external = False
+
-- Prototypes for labels defined in the runtime system are imported
-- into HC files via includes/Stg.h.
- | pkgId == rtsUnitId = False
+ | pkgId == rtsUnitId = False
-- For other labels we inline one into the HC file directly.
| otherwise = True
@@ -929,7 +961,7 @@ externallyVisibleCLabel (AsmTempLabel _) = False
externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False
externallyVisibleCLabel (RtsLabel _) = True
externallyVisibleCLabel (LocalBlockLabel _) = False
-externallyVisibleCLabel (CmmLabel _ _ _) = True
+externallyVisibleCLabel (CmmLabel _ _ _ _) = True
externallyVisibleCLabel (ForeignLabel{}) = True
externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info
externallyVisibleCLabel (CC_Label _) = True
@@ -972,14 +1004,14 @@ isGcPtrLabel lbl = case labelType lbl of
-- whether it be code, data, or static GC object.
labelType :: CLabel -> CLabelType
labelType (IdLabel _ _ info) = idInfoLabelType info
-labelType (CmmLabel _ _ CmmData) = DataLabel
-labelType (CmmLabel _ _ CmmClosure) = GcPtrLabel
-labelType (CmmLabel _ _ CmmCode) = CodeLabel
-labelType (CmmLabel _ _ CmmInfo) = DataLabel
-labelType (CmmLabel _ _ CmmEntry) = CodeLabel
-labelType (CmmLabel _ _ CmmPrimCall) = CodeLabel
-labelType (CmmLabel _ _ CmmRetInfo) = DataLabel
-labelType (CmmLabel _ _ CmmRet) = CodeLabel
+labelType (CmmLabel _ _ _ CmmData) = DataLabel
+labelType (CmmLabel _ _ _ CmmClosure) = GcPtrLabel
+labelType (CmmLabel _ _ _ CmmCode) = CodeLabel
+labelType (CmmLabel _ _ _ CmmInfo) = DataLabel
+labelType (CmmLabel _ _ _ CmmEntry) = CodeLabel
+labelType (CmmLabel _ _ _ CmmPrimCall) = CodeLabel
+labelType (CmmLabel _ _ _ CmmRetInfo) = DataLabel
+labelType (CmmLabel _ _ _ CmmRet) = CodeLabel
labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel
labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel
labelType (RtsLabel (RtsApFast _)) = CodeLabel
@@ -1049,7 +1081,7 @@ labelDynamic config this_mod lbl =
-- When compiling in the "dyn" way, each package is to be linked into
-- its own shared library.
- CmmLabel pkg _ _
+ CmmLabel pkg _ _ _
| os == OSMinGW32 -> externalDynamicRefs && (toUnitId this_pkg /= pkg)
| otherwise -> externalDynamicRefs
@@ -1248,9 +1280,9 @@ pprCLbl platform = \case
-- until that gets resolved we'll just force them to start
-- with a letter so the label will be legal assembly code.
- (CmmLabel _ str CmmCode) -> ftext str
- (CmmLabel _ str CmmData) -> ftext str
- (CmmLabel _ str CmmPrimCall) -> ftext str
+ (CmmLabel _ _ str CmmCode) -> ftext str
+ (CmmLabel _ _ str CmmData) -> ftext str
+ (CmmLabel _ _ str CmmPrimCall) -> ftext str
(LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u
@@ -1284,11 +1316,11 @@ pprCLbl platform = \case
else (sLit "_noupd_entry"))
]
- (CmmLabel _ fs CmmInfo) -> ftext fs <> text "_info"
- (CmmLabel _ fs CmmEntry) -> ftext fs <> text "_entry"
- (CmmLabel _ fs CmmRetInfo) -> ftext fs <> text "_info"
- (CmmLabel _ fs CmmRet) -> ftext fs <> text "_ret"
- (CmmLabel _ fs CmmClosure) -> ftext fs <> text "_closure"
+ (CmmLabel _ _ fs CmmInfo) -> ftext fs <> text "_info"
+ (CmmLabel _ _ fs CmmEntry) -> ftext fs <> text "_entry"
+ (CmmLabel _ _ fs CmmRetInfo) -> ftext fs <> text "_info"
+ (CmmLabel _ _ fs CmmRet) -> ftext fs <> text "_ret"
+ (CmmLabel _ _ fs CmmClosure) -> ftext fs <> text "_closure"
(RtsLabel (RtsPrimOp primop)) -> text "stg_" <> ppr primop
(RtsLabel (RtsSlowFastTickyCtr pat)) ->
=====================================
compiler/GHC/Cmm/CallConv.hs
=====================================
@@ -206,9 +206,13 @@ realArgRegsCover dflags
| passFloatArgsInXmm (targetPlatform dflags)
= map ($VGcPtr) (realVanillaRegs dflags) ++
realLongRegs dflags ++
- map XmmReg (realXmmRegNos dflags)
- | otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++
- realFloatRegs dflags ++
- realDoubleRegs dflags ++
- realLongRegs dflags ++
- map XmmReg (realXmmRegNos dflags)
+ realDoubleRegs dflags -- we only need to save the low Double part of XMM registers.
+ -- Moreover, the NCG can't load/store full XMM
+ -- registers for now...
+
+ | otherwise
+ = map ($VGcPtr) (realVanillaRegs dflags) ++
+ realFloatRegs dflags ++
+ realDoubleRegs dflags ++
+ realLongRegs dflags
+ -- we don't save XMM registers if they are not used for parameter passing
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -399,7 +399,7 @@ cmmdata :: { CmmParse () }
data_label :: { CmmParse CLabel }
: NAME ':'
{% liftP . withHomeUnitId $ \pkg ->
- return (mkCmmDataLabel pkg $1) }
+ return (mkCmmDataLabel pkg (NeedExternDecl False) $1) }
statics :: { [CmmParse [CmmStatic]] }
: {- empty -} { [] }
@@ -1115,6 +1115,9 @@ stmtMacros = listToUFM [
( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ),
( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ),
+ ( fsLit "SAVE_REGS", \[] -> emitSaveRegs ),
+ ( fsLit "RESTORE_REGS", \[] -> emitRestoreRegs ),
+
( fsLit "LDV_ENTER", \[e] -> ldvEnter e ),
( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ),
@@ -1173,7 +1176,7 @@ staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
= do dflags <- getDynFlags
let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
- code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
+ code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits
foreignCall
:: String
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -42,12 +42,14 @@ module GHC.CmmToLlvm.Base (
#include "ghcautoconf.h"
import GHC.Prelude
+import GHC.Utils.Panic
import GHC.Llvm
import GHC.CmmToLlvm.Regs
import GHC.Cmm.CLabel
-import GHC.Platform.Regs ( activeStgRegs )
+import GHC.Cmm.Ppr.Expr ()
+import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Cmm hiding ( succ )
@@ -65,7 +67,8 @@ import qualified GHC.Data.Stream as Stream
import Data.Maybe (fromJust)
import Control.Monad (ap)
import Data.Char (isDigit)
-import Data.List (sort, groupBy, intercalate)
+import Data.List (sortBy, groupBy, intercalate)
+import Data.Ord (comparing)
import qualified Data.List.NonEmpty as NE
-- ----------------------------------------------------------------------------
@@ -157,8 +160,10 @@ llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs platform live =
map (lmGlobalRegArg platform) (filter isPassed allRegs)
where allRegs = activeStgRegs platform
- paddedLive = map (\(_,r) -> r) $ padLiveArgs platform live
- isLive r = r `elem` alwaysLive || r `elem` paddedLive
+ paddingRegs = padLiveArgs platform live
+ isLive r = r `elem` alwaysLive
+ || r `elem` live
+ || r `elem` paddingRegs
isPassed r = not (isFPR r) || isLive r
@@ -170,91 +175,76 @@ isFPR (YmmReg _) = True
isFPR (ZmmReg _) = True
isFPR _ = False
-sameFPRClass :: GlobalReg -> GlobalReg -> Bool
-sameFPRClass (FloatReg _) (FloatReg _) = True
-sameFPRClass (DoubleReg _) (DoubleReg _) = True
-sameFPRClass (XmmReg _) (XmmReg _) = True
-sameFPRClass (YmmReg _) (YmmReg _) = True
-sameFPRClass (ZmmReg _) (ZmmReg _) = True
-sameFPRClass _ _ = False
-
-normalizeFPRNum :: GlobalReg -> GlobalReg
-normalizeFPRNum (FloatReg _) = FloatReg 1
-normalizeFPRNum (DoubleReg _) = DoubleReg 1
-normalizeFPRNum (XmmReg _) = XmmReg 1
-normalizeFPRNum (YmmReg _) = YmmReg 1
-normalizeFPRNum (ZmmReg _) = ZmmReg 1
-normalizeFPRNum _ = error "normalizeFPRNum expected only FPR regs"
-
-getFPRCtor :: GlobalReg -> Int -> GlobalReg
-getFPRCtor (FloatReg _) = FloatReg
-getFPRCtor (DoubleReg _) = DoubleReg
-getFPRCtor (XmmReg _) = XmmReg
-getFPRCtor (YmmReg _) = YmmReg
-getFPRCtor (ZmmReg _) = ZmmReg
-getFPRCtor _ = error "getFPRCtor expected only FPR regs"
-
-fprRegNum :: GlobalReg -> Int
-fprRegNum (FloatReg i) = i
-fprRegNum (DoubleReg i) = i
-fprRegNum (XmmReg i) = i
-fprRegNum (YmmReg i) = i
-fprRegNum (ZmmReg i) = i
-fprRegNum _ = error "fprRegNum expected only FPR regs"
-
--- | Input: dynflags, and the list of live registers
+-- | Return a list of "padding" registers for LLVM function calls.
--
--- Output: An augmented list of live registers, where padding was
--- added to the list of registers to ensure the calling convention is
--- correctly used by LLVM.
+-- When we generate LLVM function signatures, we can't just make any register
+-- alive on function entry. Instead, we need to insert fake arguments of the
+-- same register class until we are sure that one of them is mapped to the
+-- register we want alive. E.g. to ensure that F5 is alive, we may need to
+-- insert fake arguments mapped to F1, F2, F3 and F4.
--
--- Each global reg in the returned list is tagged with a bool, which
--- indicates whether the global reg was added as padding, or was an original
--- live register.
---
--- That is, True => padding, False => a real, live global register.
---
--- Also, the returned list is not sorted in any particular order.
---
-padLiveArgs :: Platform -> LiveGlobalRegs -> [(Bool, GlobalReg)]
-padLiveArgs plat live =
- if platformUnregisterised plat
- then taggedLive -- not using GHC's register convention for platform.
- else padding ++ taggedLive
+-- Invariant: Cmm FPR regs with number "n" maps to real registers with number
+-- "n" If the calling convention uses registers in a different order or if the
+-- invariant doesn't hold, this code probably won't be correct.
+padLiveArgs :: Platform -> LiveGlobalRegs -> LiveGlobalRegs
+padLiveArgs platform live =
+ if platformUnregisterised platform
+ then [] -- not using GHC's register convention for platform.
+ else padded
where
- taggedLive = map (\x -> (False, x)) live
-
- fprLive = filter isFPR live
- padding = concatMap calcPad $ groupBy sharesClass fprLive
-
- sharesClass :: GlobalReg -> GlobalReg -> Bool
- sharesClass a b = sameFPRClass a b || overlappingClass
+ ----------------------------------
+ -- handle floating-point registers (FPR)
+
+ fprLive = filter isFPR live -- real live FPR registers
+
+ -- we group live registers sharing the same classes, i.e. that use the same
+ -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg
+ -- all use the same real regs on X86-64 (XMM registers).
+ --
+ classes = groupBy sharesClass fprLive
+ sharesClass a b = regsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers
+ norm x = CmmGlobal ((fpr_ctor x) 1) -- get the first register of the family
+
+ -- For each class, we just have to fill missing registers numbers. We use
+ -- the constructor of the greatest register to build padding registers.
+ --
+ -- E.g. sortedRs = [ F2, XMM4, D5]
+ -- output = [D1, D3]
+ padded = concatMap padClass classes
+ padClass rs = go sortedRs [1..]
where
- overlappingClass = regsOverlap plat (norm a) (norm b)
- norm = CmmGlobal . normalizeFPRNum
-
- calcPad :: [GlobalReg] -> [(Bool, GlobalReg)]
- calcPad rs = getFPRPadding (getFPRCtor $ head rs) rs
-
-getFPRPadding :: (Int -> GlobalReg) -> LiveGlobalRegs -> [(Bool, GlobalReg)]
-getFPRPadding paddingCtor live = padding
- where
- fprRegNums = sort $ map fprRegNum live
- (_, padding) = foldl assignSlots (1, []) $ fprRegNums
-
- assignSlots (i, acc) regNum
- | i == regNum = -- don't need padding here
- (i+1, acc)
- | i < regNum = let -- add padding for slots i .. regNum-1
- numNeeded = regNum-i
- acc' = genPad i numNeeded ++ acc
- in
- (regNum+1, acc')
- | otherwise = error "padLiveArgs -- i > regNum ??"
-
- genPad start n =
- take n $ flip map (iterate (+1) start) (\i ->
- (True, paddingCtor i))
+ sortedRs = sortBy (comparing fpr_num) rs
+ maxr = last sortedRs
+ ctor = fpr_ctor maxr
+
+ go [] _ = []
+ go (c1:c2:_) _ -- detect bogus case (see #17920)
+ | fpr_num c1 == fpr_num c2
+ , Just real <- globalRegMaybe platform c1
+ = sorryDoc "LLVM code generator" $
+ text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <>
+ text ") both alive AND mapped to the same real register: " <> ppr real <>
+ text ". This isn't currently supported by the LLVM backend."
+ go (c:cs) (f:fs)
+ | fpr_num c == f = go cs fs -- already covered by a real register
+ | otherwise = ctor f : go (c:cs) fs -- add padding register
+ go _ _ = undefined -- unreachable
+
+ fpr_ctor :: GlobalReg -> Int -> GlobalReg
+ fpr_ctor (FloatReg _) = FloatReg
+ fpr_ctor (DoubleReg _) = DoubleReg
+ fpr_ctor (XmmReg _) = XmmReg
+ fpr_ctor (YmmReg _) = YmmReg
+ fpr_ctor (ZmmReg _) = ZmmReg
+ fpr_ctor _ = error "fpr_ctor expected only FPR regs"
+
+ fpr_num :: GlobalReg -> Int
+ fpr_num (FloatReg i) = i
+ fpr_num (DoubleReg i) = i
+ fpr_num (XmmReg i) = i
+ fpr_num (YmmReg i) = i
+ fpr_num (ZmmReg i) = i
+ fpr_num _ = error "fpr_num expected only FPR regs"
-- | Llvm standard fun attributes
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, GADTs #-}
+{-# LANGUAGE CPP, GADTs, MultiWayIf #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- ----------------------------------------------------------------------------
@@ -38,6 +38,7 @@ import GHC.Utils.Misc
import Control.Monad.Trans.Class
import Control.Monad.Trans.Writer
+import Control.Monad
import qualified Data.Semigroup as Semigroup
import Data.List ( nub )
@@ -1848,7 +1849,7 @@ funPrologue live cmmBlocks = do
isLive r = r `elem` alwaysLive || r `elem` live
platform <- getPlatform
- stmtss <- flip mapM assignedRegs $ \reg ->
+ stmtss <- forM assignedRegs $ \reg ->
case reg of
CmmLocal (LocalReg un _) -> do
let (newv, stmts) = allocReg reg
@@ -1875,9 +1876,7 @@ funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
funEpilogue live = do
platform <- getPlatform
- -- the bool indicates whether the register is padding.
- let alwaysNeeded = map (\r -> (False, r)) alwaysLive
- livePadded = alwaysNeeded ++ padLiveArgs platform live
+ let paddingRegs = padLiveArgs platform live
-- Set to value or "undef" depending on whether the register is
-- actually live
@@ -1887,14 +1886,25 @@ funEpilogue live = do
loadUndef r = do
let ty = (pLower . getVarType $ lmGlobalRegVar platform r)
return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
- platform <- getPlatform
+
+ -- Note that floating-point registers in `activeStgRegs` must be sorted
+ -- according to the calling convention.
+ -- E.g. for X86:
+ -- GOOD: F1,D1,XMM1,F2,D2,XMM2,...
+ -- BAD : F1,F2,F3,D1,D2,D3,XMM1,XMM2,XMM3,...
+ -- As Fn, Dn and XMMn use the same register (XMMn) to be passed, we don't
+ -- want to pass F2 before D1 for example, otherwise we could get F2 -> XMM1
+ -- and D1 -> XMM2.
let allRegs = activeStgRegs platform
- loads <- flip mapM allRegs $ \r -> case () of
- _ | (False, r) `elem` livePadded
- -> loadExpr r -- if r is not padding, load it
- | not (isFPR r) || (True, r) `elem` livePadded
- -> loadUndef r
- | otherwise -> return (Nothing, nilOL)
+ loads <- forM allRegs $ \r -> if
+ -- load live registers
+ | r `elem` alwaysLive -> loadExpr r
+ | r `elem` live -> loadExpr r
+ -- load all non Floating-Point Registers
+ | not (isFPR r) -> loadUndef r
+ -- load padding Floating-Point Registers
+ | r `elem` paddingRegs -> loadUndef r
+ | otherwise -> return (Nothing, nilOL)
let (vars, stmts) = unzip loads
return (catMaybes vars, concatOL stmts)
=====================================
compiler/GHC/StgToCmm/Foreign.hs
=====================================
@@ -13,6 +13,8 @@ module GHC.StgToCmm.Foreign (
emitSaveThreadState,
saveThreadState,
emitLoadThreadState,
+ emitSaveRegs,
+ emitRestoreRegs,
loadThreadState,
emitOpenNursery,
emitCloseNursery,
@@ -32,6 +34,7 @@ import GHC.Cmm.BlockId (newBlockId)
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Graph
+import GHC.Cmm.CallConv
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Cmm.CLabel
@@ -308,6 +311,32 @@ saveThreadState dflags = do
else mkNop
]
+
+
+-- | Save STG registers
+--
+-- STG registers must be saved around a C call, just in case the STG
+-- register is mapped to a caller-saves machine register. Normally we
+-- don't need to worry about this the code generator has already
+-- loaded any live STG registers into variables for us, but in
+-- hand-written low-level Cmm code where we don't know which registers
+-- are live, we might have to save them all.
+emitSaveRegs :: FCode ()
+emitSaveRegs = do
+ dflags <- getDynFlags
+ let regs = realArgRegsCover dflags
+ save = catAGraphs (map (callerSaveGlobalReg dflags) regs)
+ emit save
+
+-- | Restore STG registers (see 'emitSaveRegs')
+emitRestoreRegs :: FCode ()
+emitRestoreRegs = do
+ dflags <- getDynFlags
+ let regs = realArgRegsCover dflags
+ save = catAGraphs (map (callerRestoreGlobalReg dflags) regs)
+ emit save
+
+
emitCloseNursery :: FCode ()
emitCloseNursery = do
dflags <- getDynFlags
=====================================
compiler/GHC/StgToCmm/Prof.hs
=====================================
@@ -364,7 +364,7 @@ ldvEnter cl_ptr = do
loadEra :: DynFlags -> CmmExpr
loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth platform))
- [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))
+ [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era")))
(cInt dflags)]
where platform = targetPlatform dflags
=====================================
compiler/GHC/StgToCmm/Ticky.hs
=====================================
@@ -115,7 +115,6 @@ import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Runtime.Heap.Layout
-import GHC.Unit
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.Basic
@@ -356,7 +355,7 @@ registerTickyCtr ctr_lbl = do
, mkStore (CmmLit (cmmLabelOffB ctr_lbl
(oFFSET_StgEntCounter_registeredp dflags)))
(mkIntExpr platform 1) ]
- ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))
+ ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs"))
emit =<< mkCmmIfThen test (catAGraphs register_stmts)
tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
@@ -498,12 +497,12 @@ tickyAllocHeap genuine hp
bytes,
-- Bump the global allocation total ALLOC_HEAP_tot
addToMemLbl (bWord platform)
- (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))
+ (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_tot"))
bytes,
-- Bump the global allocation counter ALLOC_HEAP_ctr
if not genuine then mkNop
else addToMemLbl (bWord platform)
- (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))
+ (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_ctr"))
1
]}
@@ -567,13 +566,13 @@ ifTickyDynThunk :: FCode () -> FCode ()
ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code
bumpTickyCounter :: FastString -> FCode ()
-bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)
+bumpTickyCounter lbl = bumpTickyLbl (mkRtsCmmDataLabel lbl)
bumpTickyCounterBy :: FastString -> Int -> FCode ()
-bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)
+bumpTickyCounterBy lbl = bumpTickyLblBy (mkRtsCmmDataLabel lbl)
bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
-bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)
+bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl)
bumpTickyEntryCount :: CLabel -> FCode ()
bumpTickyEntryCount lbl = do
@@ -615,7 +614,7 @@ bumpHistogram lbl n = do
emit (addToMem (bWord platform)
(cmmIndexExpr platform
(wordWidth platform)
- (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))
+ (CmmLit (CmmLabel (mkRtsCmmDataLabel lbl)))
(CmmLit (CmmInt (fromIntegral offset) (wordWidth platform))))
1)
=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.StgToCmm.Utils (
tagToClosure, mkTaggedObjectLoad,
callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
+ callerSaveGlobalReg, callerRestoreGlobalReg,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
@@ -249,8 +250,8 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load)
where
platform = targetPlatform dflags
- caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save)
- caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
+ caller_save = catAGraphs (map (callerSaveGlobalReg dflags) regs_to_save)
+ caller_load = catAGraphs (map (callerRestoreGlobalReg dflags) regs_to_save)
system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
{- ,SparkHd,SparkTl,SparkBase,SparkLim -}
@@ -258,12 +259,14 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load)
regs_to_save = filter (callerSaves platform) system_regs
- callerSaveGlobalReg reg
- = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
+callerSaveGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph
+callerSaveGlobalReg dflags reg
+ = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
- callerRestoreGlobalReg reg
- = mkAssign (CmmGlobal reg)
- (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType platform reg))
+callerRestoreGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph
+callerRestoreGlobalReg dflags reg
+ = mkAssign (CmmGlobal reg)
+ (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType (targetPlatform dflags) reg))
-------------------------------------------------------------------------
=====================================
includes/Cmm.h
=====================================
@@ -739,75 +739,6 @@
TICK_BUMP(ALLOC_RTS_ctr); \
TICK_BUMP_BY(ALLOC_RTS_tot,bytes)
-/* -----------------------------------------------------------------------------
- Saving and restoring STG registers
-
- STG registers must be saved around a C call, just in case the STG
- register is mapped to a caller-saves machine register. Normally we
- don't need to worry about this the code generator has already
- loaded any live STG registers into variables for us, but in
- hand-written low-level Cmm code where we don't know which registers
- are live, we might have to save them all.
- -------------------------------------------------------------------------- */
-
-#define SAVE_STGREGS \
- W_ r1, r2, r3, r4, r5, r6, r7, r8; \
- F_ f1, f2, f3, f4, f5, f6; \
- D_ d1, d2, d3, d4, d5, d6; \
- L_ l1; \
- \
- r1 = R1; \
- r2 = R2; \
- r3 = R3; \
- r4 = R4; \
- r5 = R5; \
- r6 = R6; \
- r7 = R7; \
- r8 = R8; \
- \
- f1 = F1; \
- f2 = F2; \
- f3 = F3; \
- f4 = F4; \
- f5 = F5; \
- f6 = F6; \
- \
- d1 = D1; \
- d2 = D2; \
- d3 = D3; \
- d4 = D4; \
- d5 = D5; \
- d6 = D6; \
- \
- l1 = L1;
-
-
-#define RESTORE_STGREGS \
- R1 = r1; \
- R2 = r2; \
- R3 = r3; \
- R4 = r4; \
- R5 = r5; \
- R6 = r6; \
- R7 = r7; \
- R8 = r8; \
- \
- F1 = f1; \
- F2 = f2; \
- F3 = f3; \
- F4 = f4; \
- F5 = f5; \
- F6 = f6; \
- \
- D1 = d1; \
- D2 = d2; \
- D3 = d3; \
- D4 = d4; \
- D5 = d5; \
- D6 = d6; \
- \
- L1 = l1;
-
/* -----------------------------------------------------------------------------
Misc junk
-------------------------------------------------------------------------- */
=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -31,14 +31,14 @@ INFO_TABLE_RET (stg_stack_underflow_frame, UNDERFLOW_FRAME,
W_ new_tso;
W_ ret_off;
- SAVE_STGREGS
+ SAVE_REGS();
SAVE_THREAD_STATE();
(ret_off) = foreign "C" threadStackUnderflow(MyCapability() "ptr",
CurrentTSO);
LOAD_THREAD_STATE();
- RESTORE_STGREGS
+ RESTORE_REGS();
jump %ENTRY_CODE(Sp(ret_off)) [*]; // NB. all registers live!
}
=====================================
testsuite/driver/testlib.py
=====================================
@@ -1547,8 +1547,7 @@ def simple_build(name: Union[TestName, str],
# Required by GHC 7.3+, harmless for earlier versions:
if (getTestOpts().c_src or
getTestOpts().objc_src or
- getTestOpts().objcpp_src or
- getTestOpts().cmm_src):
+ getTestOpts().objcpp_src):
extra_hc_opts += ' -no-hs-main '
if getTestOpts().compile_cmd_prefix == '':
=====================================
testsuite/tests/cmm/should_compile/all.T
=====================================
@@ -1,4 +1,4 @@
#
-test('selfloop', [cmm_src], compile, [''])
+test('selfloop', [cmm_src], compile, ['-no-hs-main'])
test('T16930', normal, makefile_test, ['T16930'])
test('T17442', normal, compile, [''])
=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -21,15 +21,15 @@ test('massive_array',
[ when(arch('i386'), omit_ways(llvm_ways)) ],
compile, ['-fPIC'])
test('T7237', normal, compile, [''])
-test('T7574', [cmm_src, omit_ways(llvm_ways)], compile, [''])
+test('T7574', [cmm_src, omit_ways(llvm_ways)], compile, ['-no-hs-main'])
test('T8205', normal, compile, ['-O0'])
test('T9155', normal, compile, ['-O2'])
test('T9303', normal, compile, ['-O2'])
-test('T9329', [when(unregisterised(), expect_broken(15467)), cmm_src], compile, [''])
+test('T9329', [when(unregisterised(), expect_broken(15467)), cmm_src], compile, ['-no-hs-main'])
test('debug', normal, makefile_test, [])
test('T9964', normal, compile, ['-O'])
-test('T10518', [cmm_src], compile, [''])
+test('T10518', [cmm_src], compile, ['-no-hs-main'])
test('T10667', normal, compile, ['-g'])
test('T12115', normal, compile, [''])
test('T12355', normal, compile, [''])
=====================================
testsuite/tests/codeGen/should_fail/all.T
=====================================
@@ -2,6 +2,6 @@
# Only the LLVM code generator consistently forces the alignment of
# memcpy operations
-test('T8131', [cmm_src, only_ways(llvm_ways)], compile_fail, [''])
+test('T8131', [cmm_src, only_ways(llvm_ways)], compile_fail, ['-no-hs-main'])
test('T13233', normal, compile_fail, [''])
test('T13233_elab', normal, compile_fail, ['-fprint-typechecker-elaboration'])
=====================================
testsuite/tests/codeGen/should_run/T17920.cmm
=====================================
@@ -0,0 +1,28 @@
+#include "Cmm.h"
+
+section "rodata" { msg : bits8[] "Test\n"; }
+section "data" { faketso : bits8[1000]; }
+
+stg_myExit {
+ foreign "C" stg_exit(0);
+}
+
+stg_foo {
+
+ BaseReg = faketso;
+
+ SAVE_REGS();
+
+ foreign "C" printf(msg "ptr");
+
+ RESTORE_REGS();
+
+ jump stg_myExit [*]; // all registers live
+}
+
+INFO_TABLE_CONSTR(ZCMain_main,0,0,0,CONSTR_NOCAF,"MAIN","MAIN")
+{
+ jump stg_foo [];
+}
+
+CLOSURE(ZCMain_main_closure,ZCMain_main);
=====================================
testsuite/tests/codeGen/should_run/T17920.stdout
=====================================
@@ -0,0 +1 @@
+Test
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -75,8 +75,7 @@ test('cgrun066', normal, compile_and_run, [''])
test('cgrun067', [extra_files(['Cgrun067A.hs'])], compile_and_run, [''])
test('cgrun068', reqlib('random'), compile_and_run, [''])
test('cgrun069',
- [when(unregisterised(), expect_broken(15467)),
- omit_ways(['ghci'])],
+ [ omit_ways(['ghci'])],
multi_compile_and_run,
['cgrun069', [('cgrun069_cmm.cmm', '')], ''])
test('cgrun070', normal, compile_and_run, [''])
@@ -206,3 +205,5 @@ test('T15892',
test('T16617', normal, compile_and_run, [''])
test('T16449_2', exit_code(0), compile_and_run, [''])
test('T16846', [only_ways(['optasm']), exit_code(1)], compile_and_run, [''])
+
+test('T17920', cmm_src, compile_and_run, [''])
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -195,7 +195,7 @@ test('T8101b', normal, multimod_compile,
test('T10600', normal, compile_fail, ['-fno-code'])
# Should not panic when compiling cmm file together with -outputdir.
-test('T9050', cmm_src, compile, ['-outputdir=.'])
+test('T9050', cmm_src, compile, ['-outputdir=. -no-hs-main'])
test('write_interface_oneshot', [extra_files(['A011.hs'])], makefile_test, [])
=====================================
testsuite/tests/llvm/should_compile/T17920fail.cmm
=====================================
@@ -0,0 +1,35 @@
+#include "Cmm.h"
+
+section "rodata" { msg : bits8[] "Test\n"; }
+section "data" { faketso : bits8[1000]; }
+
+stg_myExit {
+ foreign "C" exit(0);
+}
+
+stg_foo {
+
+ BaseReg = faketso;
+
+ SAVE_REGS();
+
+ D_ d1;
+ F_ f1;
+
+ d1 = D1;
+ f1 = F1;
+
+ foreign "C" printf(msg "ptr");
+
+ D1 = d1;
+ F1 = f1;
+
+ RESTORE_REGS();
+
+ jump stg_myExit [*]; // all registers live
+}
+
+main {
+ jump stg_foo [];
+}
+
=====================================
testsuite/tests/llvm/should_compile/all.T
=====================================
@@ -8,7 +8,8 @@ setTestOpts(f)
# test('T5486', normal, compile, [''])
test('T5681', normal, compile, [''])
test('T6158', [reqlib('vector'), reqlib('primitive')], compile, ['-package vector -package primitive'])
-test('T7571', cmm_src, compile, [''])
+test('T7571', cmm_src, compile, ['-no-hs-main'])
test('T7575', unless(wordsize(32), skip), compile, [''])
test('T8131b', normal, compile, [''])
test('T11649', normal, compile, [''])
+test('T17920fail', cmm_src, compile_fail, ['-no-hs-main'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/809caedffe489931efa8c96a60eaed6d7ff739b9...cad62ef11972490b180fad3cd4a5c7754fa218e4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/809caedffe489931efa8c96a60eaed6d7ff739b9...cad62ef11972490b180fad3cd4a5c7754fa218e4
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200623/ecfd976d/attachment-0001.html>
More information about the ghc-commits
mailing list