[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Switch from HscSource to IsBootInterface for module lookup in GhcMake
Marge Bot
gitlab at gitlab.haskell.org
Sat Jun 20 23:04:35 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
be988a2d by John Ericson at 2020-06-20T19:03:50-04:00
Switch from HscSource to IsBootInterface for module lookup in GhcMake
We look up modules by their name, and not their contents. There is no
way to separately reference a signature vs regular module; you get what
you get. Only boot files can be referenced indepenently with `import {-#
SOURCE #-}`.
- - - - -
6bdab65b by Sylvain Henry at 2020-06-20T19:04:20-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.
- - - - -
75819b0d by Sylvain Henry at 2020-06-20T19:04:20-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).
- - - - -
17dadbf2 by Sylvain Henry at 2020-06-20T19:04:20-04:00
LLVM: refactor and comment register padding code (#17920)
- - - - -
1463aaee by Sylvain Henry at 2020-06-20T19:04:20-04:00
Add tests for #17920
Metric Decrease:
T12150
T12234
- - - - -
ffd954c0 by Simon Peyton Jones at 2020-06-20T19:04:20-04:00
Fix a buglet in Simplify.simplCast
This bug, revealed by #18347, is just a missing update to
sc_hole_ty in simplCast. I'd missed a code path when I
made the recentchanges in
commit 6d49d5be904c0c01788fa7aae1b112d5b4dfaf1c
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Thu May 21 12:53:35 2020 +0100
Implement cast worker/wrapper properly
The fix is very easy.
Two other minor changes
* Tidy up in SimpleOpt.simple_opt_expr. In fact I think this is an
outright bug, introduced in the fix to #18112: we were simplifying
the same coercion twice *with the same substitution*, which is just
wrong. It'd be a hard bug to trigger, so I just fixed it; less code
too.
* Better debug printing of ApplyToVal
- - - - -
faa12bc6 by Simon Peyton Jones at 2020-06-20T19:04:20-04:00
Two small tweaks to Coercion.simplifyArgsWorker
These tweaks affect the inner loop of simplifyArgsWorker, which
in turn is called from the flattener in Flatten.hs. This is
a key perf bottleneck to T9872{a,b,c,d}.
These two small changes have a modest but useful benefit.
No change in functionality whatsoever.
Relates to #18354
- - - - -
28 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/Core/Coercion.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Driver/Make.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
- + testsuite/tests/simplCore/should_compile/T18347.hs
- testsuite/tests/simplCore/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/Core/Coercion.hs
=====================================
@@ -1794,6 +1794,8 @@ liftCoSubstWith r tvs cos ty
-- @lc_left@ is a substitution mapping type variables to the left-hand
-- types of the mapped coercions in @lc@, and similar for @lc_right at .
liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion
+{-# INLINE liftCoSubst #-}
+-- Inlining this function is worth 2% of allocation in T9872d,
liftCoSubst r lc@(LC subst env) ty
| isEmptyVarEnv env = mkReflCo r (substTy subst ty)
| otherwise = ty_co_subst lc r ty
@@ -2846,7 +2848,9 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
-> [Role] -- Roles at which to flatten these ...
-> [(Type, Coercion)] -- flattened arguments, with their flattening coercions
-> ([Type], [Coercion], CoercionN)
- go acc_xis acc_cos lc binders inner_ki _ []
+ go acc_xis acc_cos !lc binders inner_ki _ []
+ -- The !lc makes the function strict in the lifting context
+ -- which means GHC can unbox that pair. A modest win.
= (reverse acc_xis, reverse acc_cos, kind_co)
where
final_kind = mkPiTys binders inner_ki
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -1456,7 +1456,8 @@ simplCast env body co0 cont0
= {-#SCC "addCoerce-pushCoValArg" #-}
do { tail' <- addCoerceM m_co2 tail
; if isReflCo co1
- then return (cont { sc_cont = tail' })
+ then return (cont { sc_cont = tail'
+ , sc_hole_ty = coercionLKind co })
-- Avoid simplifying if possible;
-- See Note [Avoiding exponential behaviour]
else do
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -221,9 +221,10 @@ instance Outputable SimplCont where
ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont
ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont })
= (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont
- ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont })
- = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg)
- $$ ppr cont
+ ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty })
+ = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole" <+> ppr hole_ty)
+ 2 (pprParendExpr arg))
+ $$ ppr cont
ppr (StrictBind { sc_bndr = b, sc_cont = cont })
= (text "StrictBind" <+> ppr b) $$ ppr cont
ppr (StrictArg { sc_fun = ai, sc_cont = cont })
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -213,6 +213,7 @@ simple_opt_expr env expr
in_scope = substInScope subst
in_scope_env = (in_scope, simpleUnfoldingFun)
+ ---------------
go (Var v)
| Just clo <- lookupVarEnv (soe_inl env) v
= simple_opt_clo env clo
@@ -221,17 +222,10 @@ simple_opt_expr env expr
go (App e1 e2) = simple_app env e1 [(env,e2)]
go (Type ty) = Type (substTy subst ty)
- go (Coercion co) = Coercion (optCoercion (soe_dflags env) (getTCvSubst subst) co)
+ go (Coercion co) = Coercion (go_co co)
go (Lit lit) = Lit lit
go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
- go (Cast e co) = case go e of
- -- flatten nested casts before calling the coercion optimizer;
- -- see #18112 (note that mkCast handles dropping Refl coercions)
- Cast e' co' -> mkCast e' (opt_co (mkTransCo co' co))
- e' -> mkCast e' (opt_co co)
- where
- opt_co = optCoercion (soe_dflags env) (getTCvSubst subst)
-
+ go (Cast e co) = mk_cast (go e) (go_co co)
go (Let bind body) = case simple_opt_bind env bind NotTopLevel of
(env', Nothing) -> simple_opt_expr env' body
(env', Just bind) -> Let bind (simple_opt_expr env' body)
@@ -266,6 +260,9 @@ simple_opt_expr env expr
e' = go e
(env', b') = subst_opt_bndr env b
+ ----------------------
+ go_co co = optCoercion (soe_dflags env) (getTCvSubst subst) co
+
----------------------
go_alt env (con, bndrs, rhs)
= (con, bndrs', simple_opt_expr env' rhs)
@@ -285,6 +282,15 @@ simple_opt_expr env expr
bs = reverse bs'
e' = simple_opt_expr env e
+mk_cast :: CoreExpr -> CoercionR -> CoreExpr
+-- Like GHC.Core.Utils.mkCast, but does a full reflexivity check.
+-- mkCast doesn't do that because the Simplifier does (in simplCast)
+-- But in SimpleOpt it's nice to kill those nested casts (#18112)
+mk_cast (Cast e co1) co2 = mk_cast e (co1 `mkTransCo` co2)
+mk_cast (Tick t e) co = Tick t (mk_cast e co)
+mk_cast e co | isReflexiveCo co = e
+ | otherwise = Cast e co
+
----------------------
-- simple_app collects arguments for beta reduction
simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1917,7 +1917,7 @@ reachableBackwards mod summaries
= [ node_payload node | node <- reachableG (transposeG graph) root ]
where -- the rest just sets up the graph:
(graph, lookup_node) = moduleGraphNodes False summaries
- root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
+ root = expectJust "reachableBackwards" (lookup_node IsBoot mod)
-- ---------------------------------------------------------------------------
--
@@ -1960,7 +1960,7 @@ topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod
-- the specified module. We do this by building a graph with
-- the full set of nodes, and determining the reachable set from
-- the specified node.
- let root | Just node <- lookup_node HsSrcFile root_mod
+ let root | Just node <- lookup_node NotBoot root_mod
, graph `hasVertexG` node
= node
| otherwise
@@ -1976,21 +1976,18 @@ summaryNodeSummary :: SummaryNode -> ModSummary
summaryNodeSummary = node_payload
moduleGraphNodes :: Bool -> [ModSummary]
- -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
+ -> (Graph SummaryNode, IsBootInterface -> ModuleName -> Maybe SummaryNode)
moduleGraphNodes drop_hs_boot_nodes summaries =
(graphFromEdgedVerticesUniq nodes, lookup_node)
where
numbered_summaries = zip summaries [1..]
- lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
+ lookup_node :: IsBootInterface -> ModuleName -> Maybe SummaryNode
lookup_node hs_src mod = Map.lookup
- GWIB
- { gwib_mod = mod
- , gwib_isBoot = hscSourceToIsBoot hs_src
- }
+ (GWIB { gwib_mod = mod, gwib_isBoot = hs_src })
node_map
- lookup_key :: HscSource -> ModuleName -> Maybe Int
+ lookup_key :: IsBootInterface -> ModuleName -> Maybe Int
lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
node_map :: NodeMap SummaryNode
@@ -2010,11 +2007,11 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
-- Drop the hi-boot ones if told to do so
, not (isBootSummary s == IsBoot && drop_hs_boot_nodes)
, let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
- out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
+ out_edge_keys NotBoot (map unLoc (ms_home_imps s)) ++
(-- see [boot-edges] below
if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
then []
- else case lookup_key HsBootFile (ms_mod_name s) of
+ else case lookup_key IsBoot (ms_mod_name s) of
Nothing -> []
Just k -> [k]) ]
@@ -2027,10 +2024,10 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
-- most up to date information.
-- Drop hs-boot nodes by using HsSrcFile as the key
- hs_boot_key | drop_hs_boot_nodes = HsSrcFile
- | otherwise = HsBootFile
+ hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature
+ | otherwise = IsBoot
- out_edge_keys :: HscSource -> [ModuleName] -> [Int]
+ out_edge_keys :: IsBootInterface -> [ModuleName] -> [Int]
out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms
-- If we want keep_hi_boot_nodes, then we do lookup_key with
-- IsBoot; else False
=====================================
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'])
=====================================
testsuite/tests/simplCore/should_compile/T18347.hs
=====================================
@@ -0,0 +1,10 @@
+module T18347 (function) where
+
+import Data.Coerce
+
+newtype All = All Bool
+
+data Encoding = Encoding (Char -> Bool)
+
+function :: Encoding -> Char -> All
+function enc v = coerce (case enc of Encoding x -> x) v
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -328,3 +328,4 @@ test('T18231', [ only_ways(['optasm']), grep_errmsg(r'^[\w\.]+ ::.*->.*') ], com
# Cast WW
test('T17673', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
test('T18078', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
+test('T18347', normal, compile, ['-dcore-lint -O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3894ec35475f7cc1e49d72b0eee97a68240105a9...faa12bc64c277fada86c5342a5147a7045339483
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3894ec35475f7cc1e49d72b0eee97a68240105a9...faa12bc64c277fada86c5342a5147a7045339483
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/20200620/0c86a886/attachment-0001.html>
More information about the ghc-commits
mailing list