[Git][ghc/ghc][wip/angerman/aarch64-ncg] 13 commits: [configure] fix LLVMTarget when native
Moritz Angermann
gitlab at gitlab.haskell.org
Tue Oct 20 14:38:12 UTC 2020
Moritz Angermann pushed to branch wip/angerman/aarch64-ncg at Glasgow Haskell Compiler / GHC
Commits:
13b5bca7 by Moritz Angermann at 2020-10-09T19:05:53+08:00
[configure] fix LLVMTarget when native
uname -p return "arm", hence we can't work with target_cpu,
but need to match on the target triple.
- - - - -
5cbcd9c1 by Moritz Angermann at 2020-10-09T21:28:09+08:00
[testsuite] fix subsections_via_symbols test
- - - - -
b1f7b653 by Moritz Angermann at 2020-10-09T21:32:47+08:00
[testsuite] FixT11649
- - - - -
bd8d997c by Moritz Angermann at 2020-10-15T00:31:47+08:00
Fix conc059 test
- - - - -
5f1ce1fe by Moritz Angermann at 2020-10-15T00:32:38+08:00
WIP: fix ghci adjustors on aarch64/arm (infotables)
- - - - -
e9f7e561 by Moritz Angermann at 2020-10-16T16:23:03+08:00
[DWARF] Enable only on elf platforms
- - - - -
d7027d10 by Moritz Angermann at 2020-10-16T16:35:13+08:00
[Testsuite/LLVM] Fix T5681, T7571, T8131b
- - - - -
688e9317 by Moritz Angermann at 2020-10-16T21:46:46+08:00
[testsuite/darwin] fix tests ghcilink003, ghcilink006
- - - - -
0a13e364 by Moritz Angermann at 2020-10-16T23:05:47+08:00
Fix linker_error2
- - - - -
f7564af6 by Moritz Angermann at 2020-10-20T09:37:58+08:00
Sized Hints
- - - - -
d625eab0 by Moritz Angermann at 2020-10-20T15:50:29+08:00
[Testsuite/arm64] Fix test derefnull
- - - - -
21a3f846 by Moritz Angermann at 2020-10-20T15:50:56+08:00
[testsuite/arm64] fix section_alignment
- - - - -
cb9372fd by Moritz Angermann at 2020-10-20T15:57:33+08:00
[macOS/arm64] darwinpcs :facepalm:
- - - - -
28 changed files:
- aclocal.m4
- compiler/GHC/Cmm/LayoutStack.hs
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/Cmm/Node.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/Ppr/Decl.hs
- compiler/GHC/Cmm/Type.hs
- compiler/GHC/Cmm/Utils.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/StgToCmm/Foreign.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToCmm/Utils.hs
- libraries/ghci/GHCi/InfoTable.hsc
- rts/Interpreter.c
- rts/linker/MachO.c
- rts/sm/Storage.c
- testsuite/tests/concurrent/should_run/conc059_c.c
- testsuite/tests/ghci/linking/all.T
- testsuite/tests/llvm/should_compile/all.T
- testsuite/tests/llvm/should_run/subsections_via_symbols/all.T
- testsuite/tests/llvm/should_run/subsections_via_symbols/subsections_via_symbols.m
- testsuite/tests/llvm/should_run/subsections_via_symbols/subsections_via_symbols.stdout
- testsuite/tests/rts/all.T
- testsuite/tests/rts/linker/all.T
Changes:
=====================================
aclocal.m4
=====================================
@@ -118,7 +118,7 @@ AC_DEFUN([FPTOOLS_SET_PLATFORM_VARS],
GHC_CONVERT_OS([$target_os], [$TargetArch], [TargetOS])
fi
- GHC_LLVM_TARGET([$target_cpu],[$target_vendor],[$target_os],[LlvmTarget])
+ GHC_LLVM_TARGET([$target],[$target_cpu],[$target_vendor],[$target_os],[LlvmTarget])
GHC_SELECT_FILE_EXTENSIONS([$host], [exeext_host], [soext_host])
GHC_SELECT_FILE_EXTENSIONS([$target], [exeext_target], [soext_target])
@@ -2063,19 +2063,19 @@ case "$1" in
esac
])
-# GHC_LLVM_TARGET(target_cpu, target_vendor, target_os, llvm_target_var)
+# GHC_LLVM_TARGET(target, target_cpu, target_vendor, target_os, llvm_target_var)
# --------------------------------
# converts the canonicalized target into something llvm can understand
AC_DEFUN([GHC_LLVM_TARGET], [
- llvm_target_cpu=$1
- case "$1-$2-$3" in
+ llvm_target_cpu=$2
+ case "$1" in
*-freebsd*-gnueabihf)
llvm_target_vendor="unknown"
llvm_target_os="freebsd-gnueabihf"
;;
*-hardfloat-*eabi)
llvm_target_vendor="unknown"
- llvm_target_os="$3""hf"
+ llvm_target_os="$4""hf"
;;
*-mingw32|*-mingw64|*-msys)
llvm_target_vendor="unknown"
@@ -2086,25 +2086,25 @@ AC_DEFUN([GHC_LLVM_TARGET], [
# turned into just `-linux` and fail to be found
# in the `llvm-targets` file.
*-android*|*-gnueabi*|*-musleabi*)
- GHC_CONVERT_VENDOR([$2],[llvm_target_vendor])
- llvm_target_os="$3"
+ GHC_CONVERT_VENDOR([$3],[llvm_target_vendor])
+ llvm_target_os="$4"
;;
# apple is a bit about their naming scheme for
# aarch64; and clang on macOS doesn't know that
# aarch64 would be arm64. So for LLVM we'll need
# to call it arm64; while we'll refer to it internally
# as aarch64 for consistency and sanity.
- aarch64-apple-*)
+ aarch64-apple-*|arm64-apple-*)
llvm_target_cpu="arm64"
- GHC_CONVERT_VENDOR([$2],[llvm_target_vendor])
- GHC_CONVERT_OS([$3],[$1],[llvm_target_os])
+ GHC_CONVERT_VENDOR([$3],[llvm_target_vendor])
+ GHC_CONVERT_OS([$4],[$2],[llvm_target_os])
;;
*)
- GHC_CONVERT_VENDOR([$2],[llvm_target_vendor])
- GHC_CONVERT_OS([$3],[$1],[llvm_target_os])
+ GHC_CONVERT_VENDOR([$3],[llvm_target_vendor])
+ GHC_CONVERT_OS([$4],[$2],[llvm_target_os])
;;
esac
- $4="$llvm_target_cpu-$llvm_target_vendor-$llvm_target_os"
+ $5="$llvm_target_cpu-$llvm_target_vendor-$llvm_target_os"
])
=====================================
compiler/GHC/Cmm/LayoutStack.hs
=====================================
@@ -1194,13 +1194,15 @@ lowerSafeForeignCall profile block
foreignLbl :: FastString -> CmmExpr
foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
+-- void * suspendThread (StgRegTable *, bool interruptible);
callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O
callSuspendThread platform id intrbl =
CmmUnsafeForeignCall
(ForeignTarget (foreignLbl (fsLit "suspendThread"))
- (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
+ (ForeignConvention CCallConv [AddrHint, NoHint W32] [AddrHint] CmmMayReturn))
[id] [baseExpr, mkIntExpr platform (fromEnum intrbl)]
+-- StgRegTable * resumeThread (void *);
callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread new_base id =
CmmUnsafeForeignCall
=====================================
compiler/GHC/Cmm/MachOp.hs
=====================================
@@ -655,10 +655,14 @@ pprCallishMachOp mo = text (show mo)
callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint])
callishMachOpHints op = case op of
- MO_Memcpy _ -> ([], [AddrHint,AddrHint,NoHint])
- MO_Memset _ -> ([], [AddrHint,NoHint,NoHint])
- MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])
- MO_Memcmp _ -> ([], [AddrHint, AddrHint, NoHint])
+ -- void * memcpy(void *restrict dst, const void *restrict src, size_t n);
+ MO_Memcpy _ -> ([], [AddrHint, AddrHint, NoHint W64])
+ -- void * memset(void *b, int c, size_t len);
+ MO_Memset _ -> ([], [AddrHint, SignedHint W32, NoHint W64])
+ -- void * memmove(void *dst, const void *src, size_t len);
+ MO_Memmove _ -> ([], [AddrHint, AddrHint, NoHint W64])
+ -- int memcmp(const void *s1, const void *s2, size_t n);
+ MO_Memcmp _ -> ([], [AddrHint, AddrHint, NoHint W64])
_ -> ([],[])
-- empty lists indicate NoHint
=====================================
compiler/GHC/Cmm/Node.hs
=====================================
@@ -306,8 +306,8 @@ data ForeignTarget -- The target of a foreign call
foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints target
- = ( res_hints ++ repeat NoHint
- , arg_hints ++ repeat NoHint )
+ = ( res_hints ++ repeat undefined
+ , arg_hints ++ repeat undefined )
where
(res_hints, arg_hints) =
case target of
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -1101,14 +1101,14 @@ parseSafety str = failMsgPD ("unrecognised safety: " ++ str)
parseCmmHint :: String -> PD ForeignHint
parseCmmHint "ptr" = return AddrHint
-parseCmmHint "signed" = return SignedHint
+parseCmmHint "signed" = return $ SignedHint W64
parseCmmHint str = failMsgPD ("unrecognised hint: " ++ str)
-- labels are always pointers, so we might as well infer the hint
inferCmmHint :: CmmExpr -> ForeignHint
inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
-inferCmmHint _ = NoHint
+inferCmmHint _ = NoHint W64
isPtrGlobalReg Sp = True
isPtrGlobalReg SpLim = True
=====================================
compiler/GHC/Cmm/Ppr/Decl.hs
=====================================
@@ -130,8 +130,8 @@ pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
, text "srt: " <> ppr srt ]
instance Outputable ForeignHint where
- ppr NoHint = empty
- ppr SignedHint = quotes(text "signed")
+ ppr (NoHint sz) = quotes(text "unsigned" <+> ppr sz)
+ ppr (SignedHint sz) = quotes(text "signed" <+> ppr sz)
-- ppr AddrHint = quotes(text "address")
-- Temp Jan08
ppr AddrHint = (text "PtrHint")
=====================================
compiler/GHC/Cmm/Type.hs
=====================================
@@ -18,6 +18,7 @@ module GHC.Cmm.Type
, rEP_StgEntCounter_allocd
, ForeignHint(..)
+ , hintToWidth
, Length
, vec, vec2, vec4, vec8, vec16
@@ -314,11 +315,15 @@ isVecType _ = False
-- needed by the ABI to make the correct kind of call.
data ForeignHint
- = NoHint | AddrHint | SignedHint
- deriving( Eq )
+ = NoHint Width | AddrHint | SignedHint Width
+ deriving( Eq, Show )
-- Used to give extra per-argument or per-result
-- information needed by foreign calling conventions
+hintToWidth :: ForeignHint -> Width
+hintToWidth (NoHint w) = w
+hintToWidth AddrHint = W64 -- XXX: this should be ptr size.
+hintToWidth (SignedHint w) = w
-------------------------------------------------------------------------
-- These don't really belong here, but I don't know where is best to
=====================================
compiler/GHC/Cmm/Utils.hs
=====================================
@@ -14,7 +14,7 @@
module GHC.Cmm.Utils(
-- CmmType
- primRepCmmType, slotCmmType, slotForeignHint,
+ primRepCmmType, slotCmmType,
typeCmmType, typeForeignHint, primRepForeignHint,
-- CmmLit
@@ -140,34 +140,27 @@ primElemRepCmmType DoubleElemRep = f64
typeCmmType :: Platform -> UnaryType -> CmmType
typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty)
-primRepForeignHint :: PrimRep -> ForeignHint
-primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep"
-primRepForeignHint LiftedRep = AddrHint
-primRepForeignHint UnliftedRep = AddrHint
-primRepForeignHint IntRep = SignedHint
-primRepForeignHint Int8Rep = SignedHint
-primRepForeignHint Int16Rep = SignedHint
-primRepForeignHint Int32Rep = SignedHint
-primRepForeignHint Int64Rep = SignedHint
-primRepForeignHint WordRep = NoHint
-primRepForeignHint Word8Rep = NoHint
-primRepForeignHint Word16Rep = NoHint
-primRepForeignHint Word32Rep = NoHint
-primRepForeignHint Word64Rep = NoHint
-primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg
-primRepForeignHint FloatRep = NoHint
-primRepForeignHint DoubleRep = NoHint
-primRepForeignHint (VecRep {}) = NoHint
-
-slotForeignHint :: SlotTy -> ForeignHint
-slotForeignHint PtrSlot = AddrHint
-slotForeignHint WordSlot = NoHint
-slotForeignHint Word64Slot = NoHint
-slotForeignHint FloatSlot = NoHint
-slotForeignHint DoubleSlot = NoHint
-
-typeForeignHint :: UnaryType -> ForeignHint
-typeForeignHint = primRepForeignHint . typePrimRep1
+primRepForeignHint :: Platform -> PrimRep -> ForeignHint
+primRepForeignHint _platform VoidRep = panic "primRepForeignHint:VoidRep"
+primRepForeignHint _platform LiftedRep = AddrHint
+primRepForeignHint _platform UnliftedRep = AddrHint
+primRepForeignHint platform IntRep = SignedHint (cIntWidth platform)
+primRepForeignHint _platform Int8Rep = SignedHint W8
+primRepForeignHint _platform Int16Rep = SignedHint W16
+primRepForeignHint _platform Int32Rep = SignedHint W32
+primRepForeignHint _platform Int64Rep = SignedHint W64
+primRepForeignHint platform WordRep = NoHint (wordWidth platform)
+primRepForeignHint _platform Word8Rep = NoHint W8
+primRepForeignHint _platform Word16Rep = NoHint W16
+primRepForeignHint _platform Word32Rep = NoHint W32
+primRepForeignHint _platform Word64Rep = NoHint W64
+primRepForeignHint _platform AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg
+primRepForeignHint _platform FloatRep = NoHint W32
+primRepForeignHint _platform DoubleRep = NoHint W64
+primRepForeignHint _platform (VecRep {}) = NoHint W64
+
+typeForeignHint :: Platform -> UnaryType -> ForeignHint
+typeForeignHint platform = primRepForeignHint platform . typePrimRep1
---------------------------------------------------
--
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -1184,7 +1184,7 @@ initNCGConfig dflags = NCGConfig
ArchX86 -> v
_ -> Nothing
- , ncgDwarfEnabled = debugLevel dflags > 0
- , ncgDwarfUnwindings = debugLevel dflags >= 1
- , ncgDwarfStripBlockInfo = debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1.
+ , ncgDwarfEnabled = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0
+ , ncgDwarfUnwindings = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags >= 1
+ , ncgDwarfStripBlockInfo = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1.
}
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -1092,10 +1092,20 @@ genCCall target dest_regs arg_regs bid = do
-- this will give us the format information to match on.
arg_regs' <- mapM getSomeReg arg_regs
+ -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes
+ -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in
+ -- STG; this thenn breaks packing of stack arguments, if we need to pack
+ -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type
+ -- in Cmm proper. Option two, which we choose here is to use extended Hint
+ -- information to contain the size information and use that when packing
+ -- arguments, spilled onto the stack.
+ let (_res_hints, arg_hints) = foreignTargetHints target
+ arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints
+
platform <- getPlatform
let packStack = platformOS platform == OSDarwin
- (stackSpace', passRegs, passArgumentsCode) <- passArguments packStack allGpArgRegs allFpArgRegs arg_regs' 0 [] nilOL
+ (stackSpace', passRegs, passArgumentsCode) <- passArguments packStack allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL
-- if we pack the stack, we may need to adjust to multiple of 8byte.
-- if we don't pack the stack, it will always be multiple of 8.
@@ -1242,11 +1252,11 @@ genCCall target dest_regs arg_regs bid = do
config <- getConfig
target <- cmmMakeDynamicReference config CallReference $
mkForeignLabel (fsLit name) Nothing ForeignLabelInThisPackage IsFunction
- let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn
+ let cconv = ForeignConvention CCallConv [NoHint W64] [NoHint W64] CmmMayReturn
genCCall (ForeignTarget target cconv) dest_regs arg_regs bid
-- XXX: Optimize using paired load LDP
- passArguments :: Bool -> [Reg] -> [Reg] -> [(Reg, Format, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
+ passArguments :: Bool -> [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
passArguments _packStack _ _ [] stackSpace accumRegs accumCode = return (stackSpace, accumRegs, accumCode)
-- passArguments _ _ [] accumCode stackSpace | isEven stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * stackSpace))
-- passArguments _ _ [] accumCode stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * (stackSpace + 1)))
@@ -1285,34 +1295,37 @@ genCCall target dest_regs arg_regs bid = do
-- For AArch64 specificies see: https://developer.arm.com/docs/ihi0055/latest/procedure-call-standard-for-the-arm-64-bit-architecture
--
-- Still have GP regs, and we want to pass an GP argument.
- passArguments pack (gpReg:gpRegs) fpRegs ((r, format, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do
+ passArguments pack (gpReg:gpRegs) fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do
let w = formatToWidth format
passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) (accumCode `appOL` code_r `snocOL` (ANN (text $ "Pass gp argument: " ++ show r) $ MOV (OpReg w gpReg) (OpReg w r)))
-- Still have FP regs, and we want to pass an FP argument.
- passArguments pack gpRegs (fpReg:fpRegs) ((r, format, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do
+ passArguments pack gpRegs (fpReg:fpRegs) ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do
let w = formatToWidth format
passArguments pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) (accumCode `appOL` code_r `snocOL` (ANN (text $ "Pass fp argument: " ++ show r) $ MOV (OpReg w fpReg) (OpReg w r)))
-- No mor regs left to pass. Must pass on stack.
- passArguments pack [] [] ((r, format, code_r):args) stackSpace accumRegs accumCode = do
- let w = formatToWidth format
+ passArguments pack [] [] ((r, format, hint, code_r):args) stackSpace accumRegs accumCode = do
+ let -- w = formatToWidth format
+ w = hintToWidth hint
bytes = widthInBits w `div` 8
space = if pack then bytes else 8
stackCode = code_r `snocOL` (ANN (text $ "Pass argument (size " ++ show w ++ ") on the stack: " ++ show r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace))))
passArguments pack [] [] args (stackSpace+space) accumRegs (stackCode `appOL` accumCode)
-- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.
- passArguments pack [] fpRegs ((r, format, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do
- let w = formatToWidth format
+ passArguments pack [] fpRegs ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do
+ let -- w = formatToWidth format
+ w = hintToWidth hint
bytes = widthInBits w `div` 8
space = if pack then bytes else 8
stackCode = code_r `snocOL` (ANN (text $ "Pass argument (size " ++ show w ++ ") on the stack: " ++ show r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace))))
passArguments pack [] fpRegs args (stackSpace+space) accumRegs (stackCode `appOL` accumCode)
-- Still have gpRegs left, but want to pass a FP argument. Must be passed on the stack then.
- passArguments pack gpRegs [] ((r, format, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do
- let w = formatToWidth format
+ passArguments pack gpRegs [] ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do
+ let -- w = formatToWidth format
+ w = hintToWidth hint
bytes = widthInBits w `div` 8
space = if pack then bytes else 8
stackCode = code_r `snocOL` (ANN (text $ "Pass argument (size " ++ show w ++ ") on the stack: " ++ show r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace))))
=====================================
compiler/GHC/CmmToAsm/PPC/CodeGen.hs
=====================================
@@ -1863,8 +1863,8 @@ genCCall' config gcp target dest_regs args
| isBitsType rep = intFormat (wordWidth platform)
| otherwise = cmmTypeFormat rep
conv_op = case hint of
- SignedHint -> MO_SS_Conv
- _ -> MO_UU_Conv
+ SignedHint _ -> MO_SS_Conv
+ _ -> MO_UU_Conv
stackOffset' = case gcp of
GCPAIX ->
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -2389,7 +2389,7 @@ genCCall' config is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
targetExpr <- cmmMakeDynamicReference config
CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
- [NoHint] [NoHint]
+ [NoHint W64] [NoHint W64]
CmmMayReturn)
genCCall' config is32Bit target dest_regs args bid
where
@@ -2422,7 +2422,7 @@ genCCall' config is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]
targetExpr <- cmmMakeDynamicReference config
CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
- [NoHint] [NoHint]
+ [NoHint W64] [NoHint W64]
CmmMayReturn)
genCCall' config is32Bit target dest_regs args bid
where
@@ -2455,7 +2455,7 @@ genCCall' config is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]
targetExpr <- cmmMakeDynamicReference config
CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
- [NoHint] [NoHint]
+ [NoHint W64] [NoHint W64]
CmmMayReturn)
genCCall' config is32Bit target dest_regs args bid
where
@@ -2467,7 +2467,7 @@ genCCall' config is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src]
-- Fallback to `hs_clz64` on i386
targetExpr <- cmmMakeDynamicReference config CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
- [NoHint] [NoHint]
+ [NoHint W64] [NoHint W64]
CmmMayReturn)
genCCall' config is32Bit target dest_regs args bid
@@ -2511,7 +2511,7 @@ genCCall' config is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do
targetExpr <- cmmMakeDynamicReference config
CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
- [NoHint] [NoHint]
+ [NoHint W64] [NoHint W64]
CmmMayReturn)
genCCall' config is32Bit target dest_regs args bid
where
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -1004,13 +1004,13 @@ pprCall platform ppr_fn cconv results args
pprArg (expr, AddrHint)
= cCast platform (text "void *") expr
-- see comment by machRepHintCType below
- pprArg (expr, SignedHint)
+ pprArg (expr, SignedHint _)
= cCast platform (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr
pprArg (expr, _other)
= pprExpr platform expr
- pprUnHint AddrHint rep = parens (machRepCType platform rep)
- pprUnHint SignedHint rep = parens (machRepCType platform rep)
+ pprUnHint AddrHint rep = parens (machRepCType platform rep)
+ pprUnHint (SignedHint _) rep = parens (machRepCType platform rep)
pprUnHint _ _ = empty
-- Currently we only have these two calling conventions, but this might
@@ -1174,9 +1174,9 @@ isCmmWordType platform ty = not (isFloatType ty)
-- the C compiler.
machRepHintCType :: Platform -> CmmType -> ForeignHint -> SDoc
machRepHintCType platform rep = \case
- AddrHint -> text "void *"
- SignedHint -> machRep_S_CType platform (typeWidth rep)
- _other -> machRepCType platform rep
+ AddrHint -> text "void *"
+ (SignedHint _) -> machRep_S_CType platform (typeWidth rep)
+ _other -> machRepCType platform rep
machRepPtrCType :: Platform -> CmmType -> SDoc
machRepPtrCType platform r
=====================================
compiler/GHC/StgToCmm/Foreign.hs
=====================================
@@ -606,11 +606,12 @@ getFCallArgs args typ
| otherwise
= do { cmm <- getArgAmode (NonVoid arg)
; profile <- getProfile
- ; return (Just (add_shim profile typ cmm, hint)) }
+ ; platform <- getPlatform
+ ; return (Just (add_shim profile typ cmm, hint platform)) }
where
- arg_ty = stgArgType arg
- arg_reps = typePrimRep arg_ty
- hint = typeForeignHint arg_ty
+ arg_ty = stgArgType arg
+ arg_reps = typePrimRep arg_ty
+ hint plat = typeForeignHint plat arg_ty
-- The minimum amount of information needed to determine
-- the offset to apply to an argument to a foreign call.
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -265,12 +265,12 @@ emitPrimOp dflags primop = case primop of
_ -> PrimopCmmEmit_External
-- First we handle various awkward cases specially.
-
+-- Note: StgInt newSpark (StgRegTable *reg, StgClosure *p)
ParOp -> \[arg] -> opIntoRegs $ \[res] -> do
-- for now, just implement this in a C function
-- later, we might want to inline it.
emitCCall
- [(res,NoHint)]
+ [(res,NoHint W32)]
(CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
[(baseExpr, AddrHint), (arg,AddrHint)]
@@ -281,7 +281,7 @@ emitPrimOp dflags primop = case primop of
tmp <- assignTemp arg
tmp2 <- newTemp (bWord platform)
emitCCall
- [(tmp2,NoHint)]
+ [(tmp2,NoHint W32)]
(CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
[(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -333,7 +333,7 @@ newUnboxedTupleRegs res_ty
; sequel <- getSequel
; regs <- choose_regs platform sequel
; ASSERT( regs `equalLength` reps )
- return (regs, map primRepForeignHint reps) }
+ return (regs, map (primRepForeignHint platform) reps) }
where
reps = typePrimRep res_ty
choose_regs _ (AssignTo regs _) = return regs
=====================================
libraries/ghci/GHCi/InfoTable.hsc
=====================================
@@ -359,7 +359,8 @@ sizeOfEntryCode tables_next_to_code
-- Note: Must return proper pointer for use in a closure
newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())
newExecConItbl tables_next_to_code obj con_desc
- = alloca $ \pcode -> do
+ = -- alloca $ \pcode ->
+ do
sz0 <- sizeOfEntryCode tables_next_to_code
let lcon_desc = BS.length con_desc + 1{- null terminator -}
-- SCARY
@@ -369,8 +370,10 @@ newExecConItbl tables_next_to_code obj con_desc
-- table, because on a 64-bit platform we reference this string
-- with a 32-bit offset relative to the info table, so if we
-- allocated the string separately it might be out of range.
- wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode
- ex_ptr <- peek pcode
+ wr_ptr <- _allocateWrite (sz + fromIntegral lcon_desc)
+ let ex_ptr = wr_ptr
+ -- wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode
+ -- ex_ptr <- peek pcode
let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
, infoTable = obj }
pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo
@@ -379,6 +382,7 @@ newExecConItbl tables_next_to_code obj con_desc
let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)
poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)
_flushExec sz ex_ptr -- Cache flush (if needed)
+ _markExec (sz + fromIntegral lcon_desc) ex_ptr
pure $ if tables_next_to_code
then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB
else castPtrToFunPtr ex_ptr
@@ -389,6 +393,15 @@ foreign import ccall unsafe "allocateExec"
foreign import ccall unsafe "flushExec"
_flushExec :: CUInt -> Ptr a -> IO ()
+foreign import ccall unsafe "allocateWrite"
+ _allocateWrite :: CUInt -> IO (Ptr a)
+
+foreign import ccall unsafe "markExec"
+ _markExec :: CUInt -> Ptr a -> IO ()
+
+foreign import ccall unsafe "freeWrite"
+ _freeWrite :: CUInt -> Ptr a -> IO ()
+
-- -----------------------------------------------------------------------------
-- Constants and config
=====================================
rts/Interpreter.c
=====================================
@@ -979,7 +979,7 @@ run_BCO:
bcoSize = bco->instrs->bytes / sizeof(StgWord16);
#endif
IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
-
+ IF_DEBUG(interpreter,disassemble( bco ));
#if defined(INTERP_STATS)
it_lastopc = 0; /* no opcode */
#endif
=====================================
rts/linker/MachO.c
=====================================
@@ -1505,8 +1505,10 @@ ocResolve_MachO(ObjectCode* oc)
*/
if(NULL == symbol->addr) {
symbol->addr = lookupSymbol_((char*)symbol->name);
- if(NULL == symbol->addr)
- barf("Failed to lookup symbol: %s", symbol->name);
+ if(NULL == symbol->addr) {
+ errorBelch("Failed to lookup symbol: %s", symbol->name);
+ return 0;
+ }
} else {
// we already have the address.
}
@@ -1515,10 +1517,12 @@ ocResolve_MachO(ObjectCode* oc)
* the address as well already
*/
if(NULL == symbol->addr) {
- barf("Something went wrong!");
+ errorBelch("Something went wrong!");
+ return 0;
}
if(NULL == symbol->got_addr) {
- barf("Not good either!");
+ errorBelch("Not good either!");
+ return 0;
}
*(uint64_t*)symbol->got_addr = (uint64_t)symbol->addr;
}
=====================================
rts/sm/Storage.c
=====================================
@@ -34,6 +34,10 @@
#include "Hash.h"
#endif
+#if RTS_LINKER_USE_MMAP
+#include "LinkerInternals.h"
+#endif
+
#include <string.h>
#include "ffi.h"
@@ -1745,6 +1749,20 @@ AdjustorWritable allocateExec(W_ bytes, AdjustorExecutable *exec_ret)
return writ;
}
+#if RTS_LINKER_USE_MMAP
+AdjustorWritable allocateWrite(W_ bytes) {
+ return mmapForLinker(bytes, PROT_READ | PROT_WRITE, MAP_ANONYMOUS, -1, 0);
+}
+
+void markExec(W_ bytes, AdjustorWritable writ) {
+ mmapForLinkerMarkExecutable(writ, bytes);
+}
+
+void freeWrite(W_ bytes, AdjustorWritable writ) {
+ munmap(writ, bytes);
+}
+#endif
+
AdjustorWritable execToWritable(AdjustorExecutable exec)
{
AdjustorWritable writ;
=====================================
testsuite/tests/concurrent/should_run/conc059_c.c
=====================================
@@ -2,6 +2,7 @@
#include "conc059_stub.h"
#include <unistd.h>
#include <stdio.h>
+#include <stdlib.h>
#if mingw32_HOST_OS
#include <windows.h>
#endif
=====================================
testsuite/tests/ghci/linking/all.T
=====================================
@@ -13,7 +13,11 @@ test('ghcilink002', [extra_files(['TestLink.hs', 'f.c']),
test('ghcilink003',
[unless(doing_ghci, skip),
# libstdc++ is named differently on FreeBSD
- when(opsys('freebsd'), expect_broken(17739))],
+ when(opsys('freebsd'), expect_broken(17739)),
+ # from Big Sur onwards, we can't dlopen libstdc++.dylib
+ # anymore. Will produce:
+ # dlopen(libstdc++.dylib, 5): image not found
+ when(opsys('darwin'), expect_broken(17739))],
makefile_test,
['ghcilink003'])
@@ -33,7 +37,11 @@ test('ghcilink005',
test('ghcilink006',
[unless(doing_ghci, skip),
# libstdc++ is named differently on FreeBSD
- when(opsys('freebsd'), expect_broken(17739))],
+ when(opsys('freebsd'), expect_broken(17739)),
+ # from Big Sur onwards, we can't dlopen libstdc++.dylib
+ # anymore. Will produce:
+ # dlopen(libstdc++.dylib, 5): image not found
+ when(opsys('darwin'), expect_broken(17739))],
makefile_test,
['ghcilink006'])
=====================================
testsuite/tests/llvm/should_compile/all.T
=====================================
@@ -5,11 +5,17 @@ def f( name, opts ):
setTestOpts(f)
+def ignore_llvm_and_vortex( msg ):
+ return re.sub(r"You are using an unsupported version of LLVM!.*\n",r"",
+ re.sub(r"Currently only [^ ]* is supported. System LLVM version: .*\n", r"",
+ re.sub(r"We will try though.*\n",r"",
+ re.sub(r".* is not a recognized processor for this target.*\n",r"",msg))))
+
# test('T5486', normal, compile, [''])
-test('T5681', normal, compile, [''])
+test('T5681', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile, [''])
test('T6158', [reqlib('vector'), reqlib('primitive')], compile, ['-package vector -package primitive'])
-test('T7571', cmm_src, compile, ['-no-hs-main'])
+test('T7571', [cmm_src, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile, ['-no-hs-main'])
test('T7575', unless(wordsize(32), skip), compile, [''])
-test('T8131b', normal, compile, [''])
-test('T11649', normal, compile, [''])
+test('T8131b', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile, [''])
+test('T11649', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile, [''])
test('T17920fail', cmm_src, compile_fail, ['-no-hs-main'])
=====================================
testsuite/tests/llvm/should_run/subsections_via_symbols/all.T
=====================================
@@ -3,9 +3,15 @@
#
# Please refer to https://gitlab.haskell.org/ghc/ghc/issues/5019
# for the subsections_via_symbols.stderr
+def ignore_llvm_and_vortex( msg ):
+ return re.sub(r"You are using an unsupported version of LLVM!.*\n",r"",
+ re.sub(r"Currently only [^ ]* is supported. System LLVM version: .*\n", r"",
+ re.sub(r"We will try though.*\n",r"",
+ re.sub(r".* is not a recognized processor for this target.*\n",r"",msg))))
test('subsections_via_symbols',
[when(not opsys('darwin'), skip),
only_ways(['optllvm', 'llvm', 'debugllvm']),
- extra_files(['SubsectionsViaSymbols.hs'])],
+ extra_files(['SubsectionsViaSymbols.hs']),
+ normalise_errmsg_fun(ignore_llvm_and_vortex)],
makefile_test, [])
=====================================
testsuite/tests/llvm/should_run/subsections_via_symbols/subsections_via_symbols.m
=====================================
@@ -1,6 +1,6 @@
#import <Foundation/Foundation.h>
#import "HsFFI.h"
-#import "SymbolsViaSections_stub.h"
+#import "SubsectionsViaSymbols_stub.h"
int
main(int argc, char * argv[]) {
=====================================
testsuite/tests/llvm/should_run/subsections_via_symbols/subsections_via_symbols.stdout
=====================================
@@ -1,2 +1,3 @@
+[1 of 1] Compiling SymbolsViaSections ( SubsectionsViaSymbols.hs, SubsectionsViaSymbols.o )
Linking subsections_via_symbols ...
..........
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -37,6 +37,7 @@ test('derefnull',
# The output under OS X is too unstable to readily compare
when(platform('i386-apple-darwin'), [ignore_stderr, exit_code(139)]),
when(platform('x86_64-apple-darwin'), [ignore_stderr, exit_code(139)]),
+ when(platform('aarch64-apple-darwin'), [ignore_stderr, exit_code(139)]),
when(opsys('mingw32'), [ignore_stderr, exit_code(11)]),
# since these test are supposed to crash the
# profile report will be empty always.
=====================================
testsuite/tests/rts/linker/all.T
=====================================
@@ -12,7 +12,7 @@ test('unsigned_reloc_macho_x64',
test('section_alignment',
[
extra_files(['runner.c', 'section_alignment.c']),
- unless(opsys('darwin') and arch('x86_64'), expect_broken(13624))
+ unless(opsys('darwin') and have_ncg(), expect_broken(13624))
],
run_command, ['$MAKE -s --no-print-directory section_alignment'])
@@ -104,8 +104,8 @@ test('rdynamic', [ unless(opsys('linux') or opsys('mingw32'), skip)
compile_and_run, ['-rdynamic -package ghc'])
-test('T7072',
- [extra_files(['T7072-main.c', 'T7072-obj.c']),
- unless(opsys('linux'), skip),
- req_rts_linker],
+test('T7072',
+ [extra_files(['T7072-main.c', 'T7072-obj.c']),
+ unless(opsys('linux'), skip),
+ req_rts_linker],
makefile_test, ['T7072'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/046365b34996756242037e8f62c1ac8c6e4687ff...cb9372fd94af0ff2a0c247306e450c7467d410be
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/046365b34996756242037e8f62c1ac8c6e4687ff...cb9372fd94af0ff2a0c247306e450c7467d410be
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/20201020/e8a6ba59/attachment-0001.html>
More information about the ghc-commits
mailing list