From 395412e89383d2fbfea1ddce05f0b3652afc0f9c Mon Sep 17 00:00:00 2001
From: Cheng Shao <terrorjack@type.dance>
Date: Thu, 30 May 2024 19:18:57 +0000
Subject: [PATCH] compiler/ghci/rts: remove stdcall support completely
We have formally dropped i386 windows support (#18487) a long time
ago. The stdcall foreign call convention is only used by i386 windows,
and the legacy logic around it is a significant maintenance burden for
future work that adds arm64 windows support (#24603). Therefore, this
patch removes stdcall support completely from the compiler as well as
the RTS (#24883):
- stdcall is still recognized as a FFI calling convention in Haskell
syntax. GHC will now unconditionally emit a warning
(-Wunsupported-calling-conventions) and treat it as ccall.
- Apart from minimum logic to support the parsing and warning logic,
all other code paths related to stdcall has been completely stripped
from the compiler.
- ghci only supports FFI_DEFAULT_ABI and ccall convention from now on.
- FFI foreign export adjustor code on all platforms no longer handles
the stdcall case and only handles ccall from now on.
- The Win32 specific parts of RTS no longer has special code paths for
stdcall.
This commit is the final nail on the coffin for i386 windows support.
Further commits will perform more housecleaning to strip the legacy
code paths and pave way for future arm64 windows support.
---
compiler/GHC/ByteCode/Asm.hs | 8 +--
compiler/GHC/Cmm/CLabel.hs | 68 ++++++---------------
compiler/GHC/Cmm/Node.hs | 2 +-
compiler/GHC/Cmm/Parser.y | 23 ++-----
compiler/GHC/Cmm/ThreadSanitizer.hs | 2 +-
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs | 2 +-
compiler/GHC/CmmToAsm/PIC.hs | 2 +-
compiler/GHC/CmmToAsm/PPC/CodeGen.hs | 2 +-
compiler/GHC/CmmToAsm/X86/CodeGen.hs | 31 +++-------
compiler/GHC/CmmToC.hs | 16 -----
compiler/GHC/CmmToLlvm/CodeGen.hs | 5 +-
compiler/GHC/HsToCore/Foreign/C.hs | 59 +++---------------
compiler/GHC/HsToCore/Foreign/Decl.hs | 11 ++--
compiler/GHC/HsToCore/Foreign/JavaScript.hs | 41 +++----------
compiler/GHC/HsToCore/Foreign/Wasm.hs | 5 +-
compiler/GHC/StgToByteCode.hs | 23 ++-----
compiler/GHC/StgToCmm/Bind.hs | 2 +-
compiler/GHC/StgToCmm/Foreign.hs | 18 +-----
compiler/GHC/StgToCmm/Lit.hs | 5 +-
compiler/GHC/StgToCmm/Prim.hs | 6 +-
compiler/GHC/StgToJS/Literal.hs | 4 +-
compiler/GHC/SysTools/Terminal.hs | 14 +----
compiler/GHC/Tc/Gen/Foreign.hs | 7 +--
compiler/GHC/Types/ForeignCall.hs | 15 +----
compiler/GHC/Types/Literal.hs | 27 +++-----
compiler/Language/Haskell/Syntax/Decls.hs | 2 +-
libraries/ghci/GHCi/FFI.hsc | 32 ++--------
libraries/ghci/GHCi/Message.hs | 6 +-
libraries/ghci/GHCi/Run.hs | 2 +-
rts/adjustor/LibffiAdjustor.c | 19 +-----
rts/adjustor/NativeAmd64.c | 13 +---
rts/adjustor/NativeAmd64Mingw.c | 13 +---
rts/adjustor/NativeIA64.c | 15 +----
rts/adjustor/NativePowerPC.c | 13 +---
rts/adjustor/Nativei386.c | 65 +-------------------
rts/include/rts/Adjustor.h | 3 +-
rts/include/rts/OSThreads.h | 6 +-
rts/js/mem.js | 2 +-
rts/linker/PEi386.c | 10 ++-
rts/linker/PEi386.h | 24 --------
rts/win32/OSThreads.c | 2 +-
41 files changed, 119 insertions(+), 506 deletions(-)
diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs
index 691766b8bce4..c2006a7c9f67 100644
--- a/compiler/GHC/ByteCode/Asm.hs
+++ b/compiler/GHC/ByteCode/Asm.hs
@@ -33,7 +33,6 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Core.TyCon
-import GHC.Data.FastString
import GHC.Data.FlatBag
import GHC.Data.SizedSeq
@@ -526,12 +525,7 @@ assembleI platform i = case i of
]
where
- literal (LitLabel fs (Just sz) _)
- | platformOS platform == OSMinGW32
- = litlabel (appendFS fs (mkFastString ('@':show sz)))
- -- On Windows, stdcall labels have a suffix indicating the no. of
- -- arg words, e.g. foo@8. testcase: ffi012(ghci)
- literal (LitLabel fs _ _) = litlabel fs
+ literal (LitLabel fs _) = litlabel fs
literal LitNullAddr = word 0
literal (LitFloat r) = float (fromRational r)
literal (LitDouble r) = double (fromRational r)
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index a8fa68415027..6eced164f3b8 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -132,9 +132,7 @@ module GHC.Cmm.CLabel (
ppInternalProcLabel,
-- * Others
- dynamicLinkerLabelInfo,
- addLabelSize,
- foreignLabelStdcallInfo
+ dynamicLinkerLabelInfo
) where
import GHC.Prelude
@@ -235,10 +233,6 @@ data CLabel
| ForeignLabel
FastString -- ^ name of the imported label.
- (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.
FunctionOrData
@@ -359,11 +353,10 @@ instance Ord CLabel where
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) =
+ compare (ForeignLabel a1 b1 c1) (ForeignLabel a2 b2 c2) =
uniqCompareFS a1 a2 S.<>
compare b1 b2 S.<>
- compare c1 c2 S.<>
- compare d1 d2
+ compare c1 c2
compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2
compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =
compare a1 a2 S.<>
@@ -465,8 +458,8 @@ pprDebugCLabel platform lbl = pprAsmLabel platform lbl <> parens extra
RtsLabel{}
-> text "RtsLabel"
- ForeignLabel _name mSuffix src funOrData
- -> text "ForeignLabel" <+> ppr mSuffix <+> ppr src <+> ppr funOrData
+ ForeignLabel _name src funOrData
+ -> text "ForeignLabel" <+> ppr src <+> ppr funOrData
_ -> text "other CLabel"
@@ -647,7 +640,7 @@ mkDirty_MUT_VAR_Label,
mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel,
mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel,
mkMUT_VAR_CLEAN_infoLabel :: CLabel
-mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
+mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") ForeignLabelInExternalPackage IsFunction
mkNonmovingWriteBarrierEnabledLabel
= CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData
mkOrigThunkInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo
@@ -665,8 +658,8 @@ mkSMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsL
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
-mkOutOfBoundsAccessLabel = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction
-mkMemcpyRangeOverlapLabel = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") Nothing ForeignLabelInExternalPackage IsFunction
+mkOutOfBoundsAccessLabel = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") ForeignLabelInExternalPackage IsFunction
+mkMemcpyRangeOverlapLabel = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") ForeignLabelInExternalPackage IsFunction
mkMUT_VAR_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN") CmmInfo
mkSRTInfoLabel :: Int -> CLabel
@@ -750,21 +743,12 @@ mkPrimCallLabel (PrimCall str pkg)
-- | Make a foreign label
mkForeignLabel
:: FastString -- name
- -> Maybe Int -- size prefix
-> ForeignLabelSource -- what package it's in
-> FunctionOrData
-> CLabel
mkForeignLabel = ForeignLabel
-
--- | Update the label size field in a ForeignLabel
-addLabelSize :: CLabel -> Int -> CLabel
-addLabelSize (ForeignLabel str _ src fod) sz
- = ForeignLabel str (Just sz) src fod
-addLabelSize label _
- = label
-
-- | Whether label is a top-level string literal
isBytesLabel :: CLabel -> Bool
isBytesLabel (IdLabel _ _ Bytes) = True
@@ -772,7 +756,7 @@ isBytesLabel _lbl = False
-- | Whether label is a non-haskell label (defined in C code)
isForeignLabel :: CLabel -> Bool
-isForeignLabel (ForeignLabel _ _ _ _) = True
+isForeignLabel (ForeignLabel _ _ _) = True
isForeignLabel _lbl = False
-- | Whether label is a static closure label (can come from haskell or cmm)
@@ -815,12 +799,6 @@ isConInfoTableLabel :: CLabel -> Bool
isConInfoTableLabel (IdLabel _ _ ConInfoTable {}) = True
isConInfoTableLabel _ = False
--- | Get the label size field from a ForeignLabel
-foreignLabelStdcallInfo :: CLabel -> Maybe Int
-foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info
-foreignLabelStdcallInfo _lbl = Nothing
-
-
-- Constructing Large*Labels
mkBitmapLabel :: Unique -> CLabel
mkBitmapLabel uniq = LargeBitmapLabel uniq
@@ -1052,7 +1030,7 @@ maybeLocalBlockLabel _ = Nothing
-- to the C compiler. For these labels we avoid generating our
-- own C prototypes.
isMathFun :: CLabel -> Bool
-isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs
+isMathFun (ForeignLabel fs _ _) = fs `elementOfUniqSet` math_funs
isMathFun _ = False
math_funs :: UniqSet FastString
@@ -1217,8 +1195,8 @@ labelType (RtsLabel (RtsPrimOp _)) = CodeLabel
labelType (RtsLabel (RtsSlowFastTickyCtr _)) = DataLabel
labelType (LocalBlockLabel _) = CodeLabel
labelType (SRTLabel _) = DataLabel
-labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
-labelType (ForeignLabel _ _ _ IsData) = DataLabel
+labelType (ForeignLabel _ _ IsFunction) = CodeLabel
+labelType (ForeignLabel _ _ IsData) = DataLabel
labelType (AsmTempLabel _) = panic "labelType(AsmTempLabel)"
labelType (AsmTempDerivedLabel _ _) = panic "labelType(AsmTempDerivedLabel)"
labelType (StringLitLabel _) = DataLabel
@@ -1297,7 +1275,7 @@ labelDynamic this_mod platform external_dynamic_refs lbl =
LocalBlockLabel _ -> False
- ForeignLabel _ _ source _ ->
+ ForeignLabel _ source _ ->
if os == OSMinGW32
then case source of
-- Foreign label is in some un-named foreign package (or DLL).
@@ -1424,11 +1402,11 @@ allocation. Take care if you want to remove them!
-- | Style of label pretty-printing.
--
--- When we produce C sources or headers, we have to take into account that C
--- compilers transform C labels when they convert them into symbols. For
--- example, they can add prefixes (e.g., "_" on Darwin) or suffixes (size for
--- stdcalls on Windows). So we provide two ways to pretty-print CLabels: C style
--- or Asm style.
+-- When we produce C sources or headers, we have to take into account
+-- that C compilers transform C labels when they convert them into
+-- symbols. For example, they can add prefixes (e.g., "_" on Darwin).
+-- So we provide two ways to pretty-print CLabels: C style or Asm
+-- style.
--
data LabelStyle
= CStyle -- ^ C label style (used by C and LLVM backends)
@@ -1504,17 +1482,9 @@ pprCLabelStyle !platform !sty lbl = -- see Note [Bangs in CLabel]
StringLitLabel u
-> maybe_underscore $ pprUniqueAlways u <> text "_str"
- ForeignLabel fs (Just sz) _ _
- | AsmStyle <- sty
- , OSMinGW32 <- platformOS platform
- -> -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
- -- (The C compiler does this itself).
- maybe_underscore $ ftext fs <> char '@' <> int sz
-
- ForeignLabel fs _ _ _
+ ForeignLabel fs _ _
-> maybe_underscore $ ftext fs
-
IdLabel name _cafs flavor -> case sty of
AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor
where
diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs
index 1fe3f805f346..1fbd581401c8 100644
--- a/compiler/GHC/Cmm/Node.hs
+++ b/compiler/GHC/Cmm/Node.hs
@@ -502,7 +502,7 @@ pprForeignTarget platform (PrimTarget op)
= pdoc platform
(mkForeignLabel
(mkFastString (show op))
- Nothing ForeignLabelInThisPackage IsFunction)
+ ForeignLabelInThisPackage IsFunction)
instance Outputable Convention where
ppr = pprConvention
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index 365ede9f35df..60b18ee98429 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -470,7 +470,7 @@ static :: { CmmParse [CmmStatic] }
{ do { lits <- sequence $4
; profile <- getProfile
; return $ map CmmStaticLit $
- mkStaticClosure profile (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
+ mkStaticClosure profile (mkForeignLabel $3 ForeignLabelInExternalPackage IsData)
-- mkForeignLabel because these are only used
-- for CHARLIKE and INTLIKE closures in the RTS.
dontCareCCS (map getLit lits) [] [] [] [] } }
@@ -640,11 +640,11 @@ importName
-- A label imported without an explicit packageId.
-- These are taken to come from some foreign, unnamed package.
: NAME
- { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
+ { ($1, mkForeignLabel $1 ForeignLabelInExternalPackage IsFunction) }
-- as previous 'NAME', but 'IsData'
| 'CLOSURE' NAME
- { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }
+ { ($2, mkForeignLabel $2 ForeignLabelInExternalPackage IsData) }
-- A label imported with an explicit UnitId.
| STRING NAME
@@ -748,7 +748,7 @@ expr_or_unknown
{ do e <- $1; return (Just e) }
foreignLabel :: { CmmParse CmmExpr }
- : NAME { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
+ : NAME { return (CmmLit (CmmLabel (mkForeignLabel $1 ForeignLabelInThisPackage IsFunction))) }
opt_never_returns :: { CmmReturnInfo }
: { CmmMayReturn }
@@ -1352,11 +1352,10 @@ foreignCall conv_string results_code expr_code args_code safety ret
expr <- expr_code
args <- sequence args_code
let
- expr' = adjCallTarget platform conv expr args
(arg_exprs, arg_hints) = unzip args
(res_regs, res_hints) = unzip results
fc = ForeignConvention conv arg_hints res_hints ret
- target = ForeignTarget expr' fc
+ target = ForeignTarget expr fc
_ <- code $ emitForeignCall safety res_regs target arg_exprs
return ()
@@ -1401,18 +1400,6 @@ doCall expr_code res_code args_code = do
c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
emit c
-adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
- -> CmmExpr
--- On Windows, we have to add the '@N' suffix to the label when making
--- a call with the stdcall calling convention.
-adjCallTarget platform StdCallConv (CmmLit (CmmLabel lbl)) args
- | platformOS platform == OSMinGW32
- = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
- where size (e, _) = max (platformWordSizeInBytes platform) (widthInBytes (typeWidth (cmmExprType platform e)))
- -- c.f. CgForeignCall.emitForeignCall
-adjCallTarget _ _ expr _
- = expr
-
primCall
:: [CmmParse (CmmFormal, ForeignHint)]
-> FastString
diff --git a/compiler/GHC/Cmm/ThreadSanitizer.hs b/compiler/GHC/Cmm/ThreadSanitizer.hs
index 5dfedfe21d2e..afc1273588f6 100644
--- a/compiler/GHC/Cmm/ThreadSanitizer.hs
+++ b/compiler/GHC/Cmm/ThreadSanitizer.hs
@@ -203,7 +203,7 @@ tsanTarget fn formals args =
ForeignTarget (CmmLit (CmmLabel lbl)) conv
where
conv = ForeignConvention CCallConv args formals CmmMayReturn
- lbl = mkForeignLabel fn Nothing ForeignLabelInExternalPackage IsFunction
+ lbl = mkForeignLabel fn ForeignLabelInExternalPackage IsFunction
tsanStore :: Env
-> CmmType -> CmmExpr
diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
index fa68fedfede5..9b642ea3cfff 100644
--- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
@@ -1931,7 +1931,7 @@ genCCall target dest_regs arg_regs bid = do
mkCCall name = do
config <- getConfig
target <- cmmMakeDynamicReference config CallReference $
- mkForeignLabel name Nothing ForeignLabelInThisPackage IsFunction
+ mkForeignLabel name ForeignLabelInThisPackage IsFunction
let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn
genCCall (ForeignTarget target cconv) dest_regs arg_regs bid
diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs
index 5bda90ab4553..7a07a77c23c2 100644
--- a/compiler/GHC/CmmToAsm/PIC.hs
+++ b/compiler/GHC/CmmToAsm/PIC.hs
@@ -523,7 +523,7 @@ gotLabel
-- HACK: this label isn't really foreign
= mkForeignLabel
(fsLit ".LCTOC1")
- Nothing ForeignLabelInThisPackage IsData
+ ForeignLabelInThisPackage IsData
diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
index c95f62d37e86..cca47f7bac2f 100644
--- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
@@ -1984,7 +1984,7 @@ genCCall' config gcp target dest_regs args
outOfLineMachOp mop =
do
mopExpr <- cmmMakeDynamicReference config CallReference $
- mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction
+ mkForeignLabel functionName ForeignLabelInThisPackage IsFunction
let mopLabelOrExpr = case mopExpr of
CmmLit (CmmLabel lbl) -> Left lbl
_ -> Right mopExpr
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
index 1409e9b46941..c0264ee76ea2 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -2628,7 +2628,7 @@ genLibCCall bid lbl_txt dsts args = do
-- Assume we can call these functions directly, and that they're not in a dynamic library.
-- TODO: Why is this ok? Under linux this code will be in libm.so
-- Is it because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31
- let lbl = mkForeignLabel lbl_txt Nothing ForeignLabelInThisPackage IsFunction
+ let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction
addr <- cmmMakeDynamicReference config CallReference lbl
let conv = ForeignConvention CCallConv [] [] CmmMayReturn
genCCall bid addr conv dsts args
@@ -2643,7 +2643,7 @@ genRTSCCall
genRTSCCall bid lbl_txt dsts args = do
config <- getConfig
-- Assume we can call these functions directly, and that they're not in a dynamic library.
- let lbl = mkForeignLabel lbl_txt Nothing ForeignLabelInThisPackage IsFunction
+ let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction
addr <- cmmMakeDynamicReference config CallReference lbl
let conv = ForeignConvention CCallConv [] [] CmmMayReturn
genCCall bid addr conv dsts args
@@ -2669,7 +2669,7 @@ genCCall32 :: CmmExpr -- ^ address of the function to call
-> [CmmFormal] -- ^ where to put the result
-> [CmmActual] -- ^ arguments (of mixed type)
-> NatM InstrBlock
-genCCall32 addr conv dest_regs args = do
+genCCall32 addr _ dest_regs args = do
config <- getConfig
let platform = ncgPlatform config
prom_args = map (maybePromoteCArg platform W32) args
@@ -2748,16 +2748,15 @@ genCCall32 addr conv dest_regs args = do
massert (delta == delta0 - tot_arg_size)
-- deal with static vs dynamic call targets
- (callinsns,cconv) <-
+ callinsns <-
case addr of
CmmLit (CmmLabel lbl)
- -> -- ToDo: stdcall arg sizes
- return (unitOL (CALL (Left fn_imm) []), conv)
+ -> return $ unitOL (CALL (Left fn_imm) [])
where fn_imm = ImmCLbl lbl
_
-> do { (dyn_r, dyn_c) <- getSomeReg addr
; massert (isWord32 (cmmExprType platform addr))
- ; return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
+ ; return $ dyn_c `snocOL` CALL (Right dyn_r) [] }
let push_code
| arg_pad_size /= 0
= toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),
@@ -2766,19 +2765,10 @@ genCCall32 addr conv dest_regs args = do
| otherwise
= concatOL push_codes
- -- Deallocate parameters after call for ccall;
- -- but not for stdcall (callee does it)
- --
- -- We have to pop any stack padding we added
- -- even if we are doing stdcall, though (#5052)
- pop_size
- | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size
- | otherwise = tot_arg_size
-
call = callinsns `appOL`
toOL (
- (if pop_size==0 then [] else
- [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])
+ (if tot_arg_size == 0 then [] else
+ [ADD II32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
++
[DELTA delta0]
)
@@ -3011,7 +3001,6 @@ genCCall64 addr conv dest_regs args = do
-- deal with static vs dynamic call targets
(callinsns,_cconv) <- case addr of
CmmLit (CmmLabel lbl) ->
- -- ToDo: stdcall arg sizes
return (unitOL (CALL (Left (ImmCLbl lbl)) arg_regs), conv)
_ -> do
(dyn_r, dyn_c) <- getSomeReg addr
@@ -3030,9 +3019,7 @@ genCCall64 addr conv dest_regs args = do
let call = callinsns `appOL`
toOL (
- -- Deallocate parameters after call for ccall;
- -- stdcall has callee do it, but is not supported on
- -- x86_64 target (see #3336)
+ -- Deallocate parameters after call for ccall
(if real_size==0 then [] else
[ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])
++
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index a8e060085447..cb5c6223f93a 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -243,13 +243,6 @@ pprStmt platform stmt =
fnCall =
case fn of
CmmLit (CmmLabel lbl)
- | StdCallConv <- cconv ->
- pprCall platform (pprCLabel platform lbl) cconv hresults hargs
- -- stdcall functions must be declared with
- -- a function type, otherwise the C compiler
- -- doesn't add the @n suffix to the label. We
- -- can't add the @n suffix ourselves, because
- -- it isn't valid C.
| CmmNeverReturns <- ret ->
pprCall platform cast_fn cconv hresults hargs <> semi <> text "__builtin_unreachable();"
| not (isMathFun lbl) ->
@@ -1260,7 +1253,6 @@ pprExternDecl :: Platform -> CLabel -> SDoc
pprExternDecl platform lbl
-- do not print anything for "known external" things
| not (needsCDecl lbl) = empty
- | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
| otherwise =
hcat [ visibility, label_type lbl , lparen, pprCLabel platform lbl, text ");"
-- occasionally useful to see label type
@@ -1281,14 +1273,6 @@ pprExternDecl platform lbl
| externallyVisibleCLabel lbl = char 'E'
| otherwise = char 'I'
- -- If the label we want to refer to is a stdcall function (on Windows) then
- -- we must generate an appropriate prototype for it, so that the C compiler will
- -- add the @n suffix to the label (#2276)
- stdcall_decl sz =
- text "extern __attribute__((stdcall)) void " <> pprCLabel platform lbl
- <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform))))
- <> semi
-
type TEState = (UniqSet LocalReg, Map CLabel ())
newtype TE a = TE' (State TEState a)
deriving stock (Functor)
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index 44c8788c3feb..a6cd5976429f 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -452,10 +452,7 @@ genCall target res args = do
let lmconv = case target of
ForeignTarget _ (ForeignConvention conv _ _ _) ->
case conv of
- StdCallConv -> case platformArch platform of
- ArchX86 -> CC_X86_Stdcc
- ArchX86_64 -> CC_X86_Stdcc
- _ -> CC_Ccc
+ StdCallConv -> panic "GHC.CmmToLlvm.CodeGen.genCall: StdCallConv"
CCallConv -> CC_Ccc
CApiConv -> CC_Ccc
PrimCallConv -> panic "GHC.CmmToLlvm.CodeGen.genCall: PrimCallConv"
diff --git a/compiler/GHC/HsToCore/Foreign/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs
index 8beaa8986ec5..16918dd2af11 100644
--- a/compiler/GHC/HsToCore/Foreign/C.hs
+++ b/compiler/GHC/HsToCore/Foreign/C.hs
@@ -73,7 +73,6 @@ dsCFExport:: Id -- Either the exported Id,
-> DsM ( CHeader -- contents of Module_stub.h
, CStub -- contents of Module_stub.c
, String -- string describing type to pass to createAdj.
- , Int -- size of args to stub function
)
dsCFExport fn_id co ext_name cconv isDyn = do
@@ -108,10 +107,8 @@ dsCImport :: Id
-> Safety
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
-dsCImport id co (CLabel cid) cconv _ _ = do
- dflags <- getDynFlags
+dsCImport id co (CLabel cid) _ _ _ = do
let ty = coercionLKind co
- platform = targetPlatform dflags
fod = case tyConAppTyCon_maybe (dropForAlls ty) of
Just tycon
| tyConUnique tycon == funPtrTyConKey ->
@@ -120,9 +117,8 @@ dsCImport id co (CLabel cid) cconv _ _ = do
(resTy, foRhs) <- resultWrapper ty
assert (fromJust resTy `eqType` addrPrimTy) $ -- typechecker ensures this
let
- rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
+ rhs = foRhs (Lit (LitLabel cid fod))
rhs' = Cast rhs co
- stdcall_info = fun_type_arg_stdcall_info platform cconv ty
in
return ([(id, rhs')], mempty, mempty)
@@ -175,8 +171,6 @@ dsCFExportDynamic :: Id
-> DsM ([Binding], CHeader, CStub)
dsCFExportDynamic id co0 cconv = do
mod <- getModule
- dflags <- getDynFlags
- let platform = targetPlatform dflags
let fe_nm = mkFastString $ zEncodeString
(moduleStableString mod ++ "$" ++ toCName id)
-- Construct the label based on the passed id, don't use names
@@ -189,31 +183,23 @@ dsCFExportDynamic id co0 cconv = do
export_ty = mkVisFunTyMany stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalDs ManyTy stable_ptr_ty
- (h_code, c_code, typestring, args_size) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True
+ (h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True
let
{-
The arguments to the external function which will
create a little bit of (template) code on the fly
for allowing the (stable pointed) Haskell closure
to be entered using an external calling convention
- (stdcall, ccall).
+ (ccall).
-}
- adj_args = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv))
- , Var stbl_value
- , Lit (LitLabel fe_nm mb_sz_args IsFunction)
+ adj_args = [ Var stbl_value
+ , Lit (LitLabel fe_nm IsFunction)
, Lit (mkLitString typestring)
]
-- name of external entry point providing these services.
-- (probably in the RTS.)
adjustor = fsLit "createAdjustor"
- -- Determine the number of bytes of arguments to the stub function,
- -- so that we can attach the '@N' suffix to its label if it is a
- -- stdcall on Windows.
- mb_sz_args = case cconv of
- StdCallConv -> Just args_size
- _ -> Nothing
-
ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
@@ -396,15 +382,13 @@ mkFExportCBits :: DynFlags
-> CCallConv
-> (CHeader,
CStub,
- String, -- the argument reps
- Int -- total size of arguments
+ String -- the argument reps
)
mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
=
( header_bits
, CStub body [] []
- , type_string,
- aug_arg_size
+ , type_string
)
where
platform = targetPlatform dflags
@@ -443,19 +427,6 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
| isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info
| otherwise = arg_info
- aug_arg_size = sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info]
- -- NB. the calculation here isn't strictly speaking correct.
- -- We have a primitive Haskell type (eg. Int#, Double#), and
- -- we want to know the size, when passed on the C stack, of
- -- the associated C type (eg. HsInt, HsDouble). We don't have
- -- this information to hand, but we know what GHC's conventions
- -- are for passing around the primitive Haskell types, so we
- -- use that instead. I hope the two coincide --SDM
- -- AK: This seems just wrong, the code here uses widthInBytes, but when
- -- we pass args on the haskell stack we always extend to multiples of 8
- -- to my knowledge. Not sure if it matters though so I won't touch this
- -- for now.
-
stable_ptr_arg =
(text "the_stableptr", text "StgStablePtr", undefined,
typeCmmType platform (mkStablePtrPrimTy alphaTy))
@@ -625,17 +596,3 @@ insertRetAddr _ _ args = args
ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg platform = (text "original_return_addr", text "void*", undefined,
typeCmmType platform addrPrimTy)
-
--- For stdcall labels, if the type was a FunPtr or newtype thereof,
--- then we need to calculate the size of the arguments in order to add
--- the @n suffix to the label.
-fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int
-fun_type_arg_stdcall_info platform StdCallConv ty
- | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
- tyConUnique tc == funPtrTyConKey
- = let
- (bndrs, _) = tcSplitPiTys arg_ty
- fe_arg_tys = mapMaybe anonPiTyBinderType_maybe bndrs
- in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys)
-fun_type_arg_stdcall_info _ _other_conv _
- = Nothing
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 7f5e9c975d8e..27b70cef67c6 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -95,7 +95,7 @@ dsForeigns' fos = do
, fd_e_ext = co
, fd_fe = CExport _
(L _ (CExportStatic _ ext_nm cconv)) }) = do
- (h, c, _, _, ids, bs) <- dsFExport id co ext_nm cconv False
+ (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv False
return (h, c, ids, bs)
{-
@@ -173,7 +173,6 @@ dsFExport :: Id -- Either the exported Id,
-> DsM ( CHeader -- contents of Module_stub.h
, CStub -- contents of Module_stub.c
, String -- string describing type to pass to createAdj.
- , Int -- size of args to stub function
, [Id] -- function closures to be registered as GC roots
, [Binding] -- additional bindings used by desugared foreign export
)
@@ -181,13 +180,13 @@ dsFExport fn_id co ext_name cconv is_dyn = do
platform <- getPlatform
case (platformArch platform, cconv) of
(ArchJavaScript, _) -> do
- (h, c, ts, args) <- dsJsFExport fn_id co ext_name cconv is_dyn
- pure (h, c, ts, args, [fn_id], [])
+ (h, c, ts) <- dsJsFExport fn_id co ext_name cconv is_dyn
+ pure (h, c, ts, [fn_id], [])
(ArchWasm32, JavaScriptCallConv) ->
dsWasmJSExport fn_id co ext_name
_ -> do
- (h, c, ts, args) <- dsCFExport fn_id co ext_name cconv is_dyn
- pure (h, c, ts, args, [fn_id], [])
+ (h, c, ts) <- dsCFExport fn_id co ext_name cconv is_dyn
+ pure (h, c, ts, [fn_id], [])
foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub
diff --git a/compiler/GHC/HsToCore/Foreign/JavaScript.hs b/compiler/GHC/HsToCore/Foreign/JavaScript.hs
index 790d95fd4e94..77092ab89d8e 100644
--- a/compiler/GHC/HsToCore/Foreign/JavaScript.hs
+++ b/compiler/GHC/HsToCore/Foreign/JavaScript.hs
@@ -77,7 +77,6 @@ dsJsFExport
-> DsM ( CHeader -- contents of Module_stub.h
, CStub -- contents of Module_stub.c
, String -- string describing type to pass to createAdj.
- , Int -- size of args to stub function
)
dsJsFExport fn_id co ext_name cconv isDyn = do
@@ -114,20 +113,10 @@ mkFExportJSBits
-> CCallConv
-> (CHeader,
CStub,
- String, -- the argument reps
- Int -- total size of arguments
+ String -- the argument reps
)
mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
- = (header_bits, js_bits, type_string,
- sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- arg_info] -- all the args
- -- NB. the calculation here isn't strictly speaking correct.
- -- We have a primitive Haskell type (eg. Int#, Double#), and
- -- we want to know the size, when passed on the C stack, of
- -- the associated C type (eg. HsInt, HsDouble). We don't have
- -- this information to hand, but we know what GHC's conventions
- -- are for passing around the primitive Haskell types, so we
- -- use that instead. I hope the two coincide --SDM
- )
+ = (header_bits, js_bits, type_string)
where
-- list the arguments to the JS function
arg_info :: [(SDoc, -- arg name
@@ -242,7 +231,7 @@ dsJsImport
-> Safety
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
-dsJsImport id co (CLabel cid) cconv _ _ = do
+dsJsImport id co (CLabel cid) _ _ _ = do
let ty = coercionLKind co
fod = case tyConAppTyCon_maybe (dropForAlls ty) of
Just tycon
@@ -251,9 +240,8 @@ dsJsImport id co (CLabel cid) cconv _ _ = do
_ -> IsData
(_resTy, foRhs) <- jsResultWrapper ty
-- ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
- let rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
+ let rhs = foRhs (Lit (LitLabel cid fod))
rhs' = Cast rhs co
- stdcall_info = fun_type_arg_stdcall_info cconv ty
return ([(id, rhs')], mempty, mempty)
@@ -280,7 +268,6 @@ dsJsFExportDynamic id co0 cconv = do
-- Must have an IO type; hence Just
$ tcSplitIOType_maybe fn_res_ty
mod <- getModule
- platform <- targetPlatform <$> getDynFlags
let fe_nm = mkFastString $ zEncodeString
("h$" ++ moduleStableString mod ++ "$" ++ toJsName id)
-- Construct the label based on the passed id, don't use names
@@ -293,31 +280,23 @@ dsJsFExportDynamic id co0 cconv = do
export_ty = mkVisFunTyMany stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalDs ManyTy stable_ptr_ty
- (h_code, c_code, typestring, args_size) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True
+ (h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True
let
{-
The arguments to the external function which will
create a little bit of (template) code on the fly
for allowing the (stable pointed) Haskell closure
to be entered using an external calling convention
- (stdcall, ccall).
+ (ccall).
-}
- adj_args = [ mkIntLit platform (toInteger (ccallConvToInt cconv))
- , Var stbl_value
- , Lit (LitLabel fe_nm mb_sz_args IsFunction)
+ adj_args = [ Var stbl_value
+ , Lit (LitLabel fe_nm IsFunction)
, Lit (mkLitString typestring)
]
-- name of external entry point providing these services.
-- (probably in the RTS.)
adjustor = fsLit "createAdjustor"
- -- Determine the number of bytes of arguments to the stub function,
- -- so that we can attach the '@N' suffix to its label if it is a
- -- stdcall on Windows.
- mb_sz_args = case cconv of
- StdCallConv -> Just args_size
- _ -> Nothing
-
ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
@@ -568,10 +547,6 @@ mk_alt return_result (Just prim_res_ty, wrap_result)
the_alt = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs
return (ccall_res_ty, the_alt)
-fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
-fun_type_arg_stdcall_info _other_conv _ = Nothing
-
-
jsResultWrapper
:: Type
-> DsM ( Maybe Type -- Type of the expected result, if any
diff --git a/compiler/GHC/HsToCore/Foreign/Wasm.hs b/compiler/GHC/HsToCore/Foreign/Wasm.hs
index 1e92ed7418a5..302b939e2626 100644
--- a/compiler/GHC/HsToCore/Foreign/Wasm.hs
+++ b/compiler/GHC/HsToCore/Foreign/Wasm.hs
@@ -136,7 +136,7 @@ dsWasmJSDynamicExport fn_id co mUnitId = do
(Var unsafeDupablePerformIO_id)
[Type arg_ty, mkApps (Var deRefStablePtr_id) [Type arg_ty, Var sp_id]]
work_ty = exprType work_rhs
- (work_h, work_c, _, _, work_ids, work_bs) <-
+ (work_h, work_c, _, work_ids, work_bs) <-
dsWasmJSExport
work_id
(mkRepReflCo work_ty)
@@ -597,7 +597,7 @@ dsWasmJSExport ::
Id ->
Coercion ->
CLabelString ->
- DsM (CHeader, CStub, String, Int, [Id], [Binding])
+ DsM (CHeader, CStub, String, [Id], [Binding])
dsWasmJSExport fn_id co ext_name = do
work_uniq <- newUnique
let ty = coercionRKind co
@@ -697,7 +697,6 @@ dsWasmJSExport fn_id co ext_name = do
( CHeader commonCDecls,
CStub cstub [] [],
"",
- -1,
[work_id],
[(work_id, work_rhs)]
)
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index a044c074ae99..e587053992f1 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -1393,7 +1393,7 @@ generatePrimCall d s p target _mb_unit _result_ty args
prim_args_offsets = mapFst stgArgRepU args_offsets
shifted_args_offsets = mapSnd (+ d) args_offsets
- push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1
+ push_target = PUSH_UBX (LitLabel target IsFunction) 1
push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1
{-
compute size to move payload (without stg_primcall_info header)
@@ -1438,7 +1438,7 @@ generateCCall d0 s p (CCallSpec target PrimCallConv _) result_ty args
= generatePrimCall d0 s p label mb_unit result_ty args
| otherwise
= panic "GHC.StgToByteCode.generateCCall: primcall convention only supports static targets"
-generateCCall d0 s p (CCallSpec target cconv safety) result_ty args
+generateCCall d0 s p (CCallSpec target _ safety) result_ty args
= do
profile <- getProfile
@@ -1546,14 +1546,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args
StaticTarget _ _ _ False ->
panic "generateCCall: unexpected FFI value import"
StaticTarget _ target _ True ->
- Just (LitLabel target mb_size IsFunction)
- where
- mb_size
- | OSMinGW32 <- platformOS platform
- , StdCallConv <- cconv
- = Just (fromIntegral a_reps_sizeW * platformWordSizeInBytes platform)
- | otherwise
- = Nothing
+ Just (LitLabel target IsFunction)
let
is_static = isJust maybe_static_target
@@ -1587,12 +1580,6 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args
-- is. See comment in Interpreter.c with the CCALL instruction.
stk_offset = bytesToWords platform (d_after_r - s)
- conv = case cconv of
- CCallConv -> FFICCall
- CApiConv -> FFICCall
- StdCallConv -> FFIStdCall
- _ -> panic "GHC.StgToByteCode: unexpected calling convention"
-
-- the only difference in libffi mode is that we prepare a cif
-- describing the call type by calling libffi, and we attach the
-- address of this to the CCALL instruction.
@@ -1601,7 +1588,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args
let ffires = primRepToFFIType platform r_rep
ffiargs = map (primRepToFFIType platform) a_reps
interp <- hscInterp <$> getHscEnv
- token <- ioToBc $ interpCmd interp (PrepFFI conv ffiargs ffires)
+ token <- ioToBc $ interpCmd interp (PrepFFI ffiargs ffires)
recordFFIBc token
let
@@ -2148,7 +2135,7 @@ isFollowableArg _ = False
isSupportedCConv :: CCallSpec -> Bool
isSupportedCConv (CCallSpec _ cconv _) = case cconv of
CCallConv -> True -- we explicitly pattern match on every
- StdCallConv -> True -- convention to ensure that a warning
+ StdCallConv -> False -- convention to ensure that a warning
PrimCallConv -> True -- is triggered when a new one is added
JavaScriptCallConv -> False
CApiConv -> True
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index d12d73208922..b667008b83f5 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -861,7 +861,7 @@ link_caf node = do
{ cfg <- getStgToCmmConfig
-- Call the RTS function newCAF, returning the newly-allocated
-- blackhole indirection closure
- ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing
+ ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF")
ForeignLabelInExternalPackage IsFunction
; let profile = stgToCmmProfile cfg
; let platform = profilePlatform profile
diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs
index 7464eda718c2..e1f5a59a4dcb 100644
--- a/compiler/GHC/StgToCmm/Foreign.hs
+++ b/compiler/GHC/StgToCmm/Foreign.hs
@@ -72,20 +72,7 @@ cgForeignCall :: ForeignCall -- the op
-> FCode ReturnKind
cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
- = do { platform <- getPlatform
- ; let -- in the stdcall calling convention, the symbol needs @size appended
- -- to it, where size is the total number of bytes of arguments. We
- -- attach this info to the CLabel here, and the CLabel pretty printer
- -- will generate the suffix when the label is printed.
- call_size args
- | StdCallConv <- cconv = Just (sum (map arg_size args))
- | otherwise = Nothing
-
- -- ToDo: this might not be correct for 64-bit API
- -- This is correct for the PowerPC ELF ABI version 1 and 2.
- arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType platform arg)
- (platformWordSizeInBytes platform)
- ; cmm_args <- getFCallArgs stg_args typ
+ = do { cmm_args <- getFCallArgs stg_args typ
-- ; traceM $ show cmm_args
; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
; let ((call_args, arg_hints), cmm_target)
@@ -97,10 +84,9 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
= case mPkgId of
Nothing -> ForeignLabelInThisPackage
Just pkgId -> ForeignLabelInPackage (toUnitId pkgId)
- size = call_size cmm_args
in ( unzip cmm_args
, CmmLit (CmmLabel
- (mkForeignLabel lbl size labelSource IsFunction)))
+ (mkForeignLabel lbl labelSource IsFunction)))
DynamicTarget -> case cmm_args of
(fn,_):rest -> (unzip rest, fn)
diff --git a/compiler/GHC/StgToCmm/Lit.hs b/compiler/GHC/StgToCmm/Lit.hs
index f4815c56caf0..53de40b712ea 100644
--- a/compiler/GHC/StgToCmm/Lit.hs
+++ b/compiler/GHC/StgToCmm/Lit.hs
@@ -97,9 +97,8 @@ mkSimpleLit platform = \case
(LitNumber LitNumWord64 i) -> CmmInt i W64
(LitFloat r) -> CmmFloat r W32
(LitDouble r) -> CmmFloat r W64
- (LitLabel fs ms fod)
+ (LitLabel fs fod)
-> let -- TODO: Literal labels might not actually be in the current package...
labelSrc = ForeignLabelInThisPackage
- in CmmLabel (mkForeignLabel fs ms labelSrc fod)
+ in CmmLabel (mkForeignLabel fs labelSrc fod)
other -> pprPanic "mkSimpleLit" (ppr other)
-
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index b957b11b3e89..4d272fda6b5e 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -253,7 +253,7 @@ emitPrimOp cfg primop =
-- later, we might want to inline it.
emitCCall
[(res,NoHint)]
- (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
+ (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") ForeignLabelInExternalPackage IsFunction)))
[(baseExpr platform, AddrHint), (arg,AddrHint)]
SparkOp -> \[arg] -> opIntoRegs $ \[res] -> do
@@ -264,7 +264,7 @@ emitPrimOp cfg primop =
tmp2 <- newTemp (bWord platform)
emitCCall
[(tmp2,NoHint)]
- (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
+ (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") ForeignLabelInExternalPackage IsFunction)))
[(baseExpr platform, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
@@ -2289,7 +2289,7 @@ fmaCCall width res arg_x arg_y arg_z =
(CmmLit (CmmLabel fma_lbl))
[(arg_x,NoHint), (arg_y,NoHint), (arg_z,NoHint)]
where
- fma_lbl = mkForeignLabel fma_op Nothing ForeignLabelInExternalPackage IsFunction
+ fma_lbl = mkForeignLabel fma_op ForeignLabelInExternalPackage IsFunction
fma_op = case width of
W32 -> fsLit "fmaf"
W64 -> fsLit "fma"
diff --git a/compiler/GHC/StgToJS/Literal.hs b/compiler/GHC/StgToJS/Literal.hs
index f967d9b8dd35..74958983e883 100644
--- a/compiler/GHC/StgToJS/Literal.hs
+++ b/compiler/GHC/StgToJS/Literal.hs
@@ -61,7 +61,7 @@ genLit = \case
LitNumBigNat -> panic "genLit: unexpected BigNat that should have been removed in CorePrep"
LitFloat r -> return [ toJExpr (r2f r) ]
LitDouble r -> return [ toJExpr (r2d r) ]
- LitLabel name _size fod
+ LitLabel name fod
| fod == IsFunction -> return [ ApplExpr (var "h$mkFunctionPtr")
[var (mkRawSymbol True name)]
, ValExpr (JInt 0)
@@ -113,7 +113,7 @@ genStaticLit = \case
LitNumBigNat -> panic "genStaticLit: unexpected BigNat that should have been removed in CorePrep"
LitFloat r -> return [ DoubleLit . SaneDouble . r2f $ r ]
LitDouble r -> return [ DoubleLit . SaneDouble . r2d $ r ]
- LitLabel name _size fod -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name)
+ LitLabel name fod -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name)
, IntLit 0 ]
l -> pprPanic "genStaticLit" (ppr l)
diff --git a/compiler/GHC/SysTools/Terminal.hs b/compiler/GHC/SysTools/Terminal.hs
index a3f60e24363c..9157f7187408 100644
--- a/compiler/GHC/SysTools/Terminal.hs
+++ b/compiler/GHC/SysTools/Terminal.hs
@@ -17,16 +17,6 @@ import qualified System.Win32 as Win32
import System.IO.Unsafe
-#if defined(mingw32_HOST_OS) && !defined(WINAPI)
-# if defined(i386_HOST_ARCH)
-# define WINAPI stdcall
-# elif defined(x86_64_HOST_ARCH)
-# define WINAPI ccall
-# else
-# error unknown architecture
-# endif
-#endif
-
-- | Does the controlling terminal support ANSI color sequences?
-- This memoized to avoid thread-safety issues in ncurses (see #17922).
stderrSupportsAnsiColors :: Bool
@@ -84,10 +74,10 @@ setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO ()
setConsoleMode h mode = do
Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode)
-foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode
+foreign import ccall unsafe "windows.h GetConsoleMode" c_GetConsoleMode
:: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL
-foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode
+foreign import ccall unsafe "windows.h SetConsoleMode" c_SetConsoleMode
:: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL
#endif
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index e1870c504485..a8019b396310 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -557,11 +557,7 @@ checkCConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
checkCConv _ CCallConv = return CCallConv
checkCConv _ CApiConv = return CApiConv
checkCConv decl StdCallConv = do
- dflags <- getDynFlags
- let platform = targetPlatform dflags
- if platformArch platform == ArchX86
- then return StdCallConv
- else do -- This is a warning, not an error. see #3336
+ -- This is a warning, not an error. see #3336
let msg = TcRnUnsupportedCallConv decl StdCallConvUnsupported
addDiagnosticTc msg
return CCallConv
@@ -798,4 +794,3 @@ validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes dflags
| xopt LangExt.UnliftedFFITypes dflags = IsValid
| otherwise = NotValid UnliftedFFITypesNeeded
-
diff --git a/compiler/GHC/Types/ForeignCall.hs b/compiler/GHC/Types/ForeignCall.hs
index 8cfa4805ac2a..b99eb931a538 100644
--- a/compiler/GHC/Types/ForeignCall.hs
+++ b/compiler/GHC/Types/ForeignCall.hs
@@ -13,7 +13,7 @@ module GHC.Types.ForeignCall (
CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
CCallSpec(..),
CCallTarget(..), isDynamicTarget,
- CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
+ CCallConv(..), defaultCCallConv, ccallConvAttribute,
Header(..), CType(..),
) where
@@ -146,10 +146,6 @@ Stuff to do with calling convention:
ccall: Caller allocates parameters, *and* deallocates them.
-stdcall: Caller allocates parameters, callee deallocates.
- Function name has @N after it, where N is number of arg bytes
- e.g. _Foo@8. This convention is x86 (win32) specific.
-
See: http://www.programmersheaven.com/2/Calling-conventions
-}
@@ -172,20 +168,13 @@ instance Outputable CCallConv where
defaultCCallConv :: CCallConv
defaultCCallConv = CCallConv
-ccallConvToInt :: CCallConv -> Int
-ccallConvToInt StdCallConv = 0
-ccallConvToInt CCallConv = 1
-ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv"
-ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
-ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"
-
{-
Generate the gcc attribute corresponding to the given
calling convention (used by PprAbsC):
-}
ccallConvAttribute :: CCallConv -> SDoc
-ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))"
+ccallConvAttribute StdCallConv = panic "ccallConvAttribute StdCallConv"
ccallConvAttribute CCallConv = empty
ccallConvAttribute CApiConv = empty
ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs
index ce9718f9c24e..571fb4422fb4 100644
--- a/compiler/GHC/Types/Literal.hs
+++ b/compiler/GHC/Types/Literal.hs
@@ -145,19 +145,13 @@ data Literal
| LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat'
| LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble'
- | LitLabel FastString (Maybe Int) FunctionOrData
+ | LitLabel FastString FunctionOrData
-- ^ A label literal. Parameters:
--
-- 1) The name of the symbol mentioned in the
-- declaration
--
- -- 2) The size (in bytes) of the arguments
- -- the label expects. Only applicable with
- -- @stdcall@ labels. @Just x@ => @\<x\>@ will
- -- be appended to label name when emitting
- -- assembly.
- --
- -- 3) Flag indicating whether the symbol
+ -- 2) Flag indicating whether the symbol
-- references a function or a data
deriving Data
@@ -259,10 +253,9 @@ instance Binary Literal where
put_ bh (LitNullAddr) = putByte bh 2
put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah
put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai
- put_ bh (LitLabel aj mb fod)
+ put_ bh (LitLabel aj fod)
= do putByte bh 5
put_ bh aj
- put_ bh mb
put_ bh fod
put_ bh (LitNumber nt i)
= do putByte bh 6
@@ -289,9 +282,8 @@ instance Binary Literal where
return (LitDouble ai)
5 -> do
aj <- get bh
- mb <- get bh
fod <- get bh
- return (LitLabel aj mb fod)
+ return (LitLabel aj fod)
6 -> do
nt <- get bh
i <- get bh
@@ -843,7 +835,7 @@ literalType (LitChar _) = charPrimTy
literalType (LitString _) = addrPrimTy
literalType (LitFloat _) = floatPrimTy
literalType (LitDouble _) = doublePrimTy
-literalType (LitLabel _ _ _) = addrPrimTy
+literalType (LitLabel _ _) = addrPrimTy
literalType (LitNumber lt _) = case lt of
LitNumBigNat -> byteArrayPrimTy
LitNumInt -> intPrimTy
@@ -874,7 +866,7 @@ cmpLit (LitString a) (LitString b) = a `compare` b
cmpLit (LitNullAddr) (LitNullAddr) = EQ
cmpLit (LitFloat a) (LitFloat b) = a `compare` b
cmpLit (LitDouble a) (LitDouble b) = a `compare` b
-cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `lexicalCompareFS` b
+cmpLit (LitLabel a _) (LitLabel b _) = a `lexicalCompareFS` b
cmpLit (LitNumber nt1 a) (LitNumber nt2 b)
= (nt1 `compare` nt2) `mappend` (a `compare` b)
cmpLit (LitRubbish tc1 b1) (LitRubbish tc2 b2) = (tc1 `compare` tc2) `mappend`
@@ -908,11 +900,8 @@ pprLiteral _ (LitNumber nt i)
LitNumWord16 -> pprPrimWord16 i
LitNumWord32 -> pprPrimWord32 i
LitNumWord64 -> pprPrimWord64 i
-pprLiteral add_par (LitLabel l mb fod) =
- add_par (text "__label" <+> b <+> ppr fod)
- where b = case mb of
- Nothing -> pprHsString l
- Just x -> doubleQuotes (ftext l <> text ('@':show x))
+pprLiteral add_par (LitLabel l fod) =
+ add_par (text "__label" <+> pprHsString l <+> ppr fod)
pprLiteral _ (LitRubbish torc rep)
= text "RUBBISH" <> pp_tc <> parens (ppr rep)
where
diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs
index 5f9f4908a1f1..4af634ac6e96 100644
--- a/compiler/Language/Haskell/Syntax/Decls.hs
+++ b/compiler/Language/Haskell/Syntax/Decls.hs
@@ -1588,7 +1588,7 @@ data ForeignImport pass = -- import of a C entity
-- * `Safety' is irrelevant for `CLabel' and `CWrapper'
--
CImport (XCImport pass)
- (XRec pass CCallConv) -- ccall or stdcall
+ (XRec pass CCallConv) -- ccall
(XRec pass Safety) -- interruptible, safe or unsafe
(Maybe Header) -- name of C header
CImportSpec -- details of the C entity
diff --git a/libraries/ghci/GHCi/FFI.hsc b/libraries/ghci/GHCi/FFI.hsc
index 301fb55ef62e..f88a7b0dd678 100644
--- a/libraries/ghci/GHCi/FFI.hsc
+++ b/libraries/ghci/GHCi/FFI.hsc
@@ -36,7 +36,6 @@
{-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-}
module GHCi.FFI
( FFIType(..)
- , FFIConv(..)
, C_ffi_cif
, prepForeignCall
, freeForeignCallInfo
@@ -66,36 +65,27 @@ data FFIType
| FFIUInt64
deriving (Show, Generic, Binary)
-data FFIConv
- = FFICCall
- | FFIStdCall
- deriving (Show, Generic, Binary)
-
-
prepForeignCall
- :: FFIConv
- -> [FFIType] -- arg types
+ :: [FFIType] -- arg types
-> FFIType -- result type
-> IO (Ptr C_ffi_cif) -- token for making calls (must be freed by caller)
#if !defined(javascript_HOST_ARCH)
-prepForeignCall cconv arg_types result_type = do
+prepForeignCall arg_types result_type = do
let n_args = length arg_types
arg_arr <- mallocArray n_args
pokeArray arg_arr (map ffiType arg_types)
cif <- mallocBytes (#const sizeof(ffi_cif))
- let abi = convToABI cconv
- r <- ffi_prep_cif cif abi (fromIntegral n_args) (ffiType result_type) arg_arr
+ r <- ffi_prep_cif cif fFI_DEFAULT_ABI (fromIntegral n_args) (ffiType result_type) arg_arr
if r /= fFI_OK then
throwIO $ ErrorCall $ concat
[ "prepForeignCallFailed: ", strError r,
- "(cconv: ", show cconv,
- " arg tys: ", show arg_types,
+ "(arg tys: ", show arg_types,
" res ty: ", show result_type, ")" ]
else
return (castPtr cif)
#else
-prepForeignCall _ _ _ =
+prepForeignCall _ _ =
error "GHCi.FFI.prepForeignCall: Called with JS_HOST_ARCH! Perhaps you need to run configure?"
#endif
@@ -124,14 +114,6 @@ strError r
| otherwise
= "unknown error: " ++ show r
-convToABI :: FFIConv -> C_ffi_abi
-convToABI FFICCall = fFI_DEFAULT_ABI
-#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
-convToABI FFIStdCall = fFI_STDCALL
-#endif
--- unknown conventions are mapped to the default, (#3336)
-convToABI _ = fFI_DEFAULT_ABI
-
ffiType :: FFIType -> Ptr C_ffi_type
ffiType FFIVoid = ffi_type_void
ffiType FFIPointer = ffi_type_pointer
@@ -169,10 +151,6 @@ fFI_BAD_TYPEDEF = (#const FFI_BAD_TYPEDEF)
fFI_DEFAULT_ABI :: C_ffi_abi
fFI_DEFAULT_ABI = (#const FFI_DEFAULT_ABI)
-#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
-fFI_STDCALL :: C_ffi_abi
-fFI_STDCALL = (#const FFI_STDCALL)
-#endif
-- ffi_status ffi_prep_cif(ffi_cif *cif,
-- ffi_abi abi,
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 09efb86cdbff..fa211be8dec6 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -103,7 +103,7 @@ data Message a where
MallocStrings :: [ByteString] -> Message [RemotePtr ()]
-- | Calls 'GHCi.FFI.prepareForeignCall'
- PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)
+ PrepFFI :: [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)
-- | Free data previously created by 'PrepFFI'
FreeFFI :: RemotePtr C_ffi_cif -> Message ()
@@ -526,7 +526,7 @@ getMessage = do
13 -> Msg <$> FreeHValueRefs <$> get
14 -> Msg <$> MallocData <$> get
15 -> Msg <$> MallocStrings <$> get
- 16 -> Msg <$> (PrepFFI <$> get <*> get <*> get)
+ 16 -> Msg <$> (PrepFFI <$> get <*> get)
17 -> Msg <$> FreeFFI <$> get
18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get <*> get)
19 -> Msg <$> (EvalStmt <$> get <*> get)
@@ -572,7 +572,7 @@ putMessage m = case m of
FreeHValueRefs val -> putWord8 13 >> put val
MallocData bs -> putWord8 14 >> put bs
MallocStrings bss -> putWord8 15 >> put bss
- PrepFFI conv args res -> putWord8 16 >> put conv >> put args >> put res
+ PrepFFI args res -> putWord8 16 >> put args >> put res
FreeFFI p -> putWord8 17 >> put p
MkConInfoTable tc p n t pt d -> putWord8 18 >> put tc >> put p >> put n >> put t >> put pt >> put d
EvalStmt opts val -> putWord8 19 >> put opts >> put val
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index 26492af2d9eb..815d1686bb80 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -109,7 +109,7 @@ run m = case m of
mapM mkRemoteRef =<< getIdValFromApStack aps ix
MallocData bs -> mkString bs
MallocStrings bss -> mapM mkString0 bss
- PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
+ PrepFFI args res -> toRemotePtr <$> prepForeignCall args res
FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
StartTH -> startTH
GetClosure ref -> do
diff --git a/rts/adjustor/LibffiAdjustor.c b/rts/adjustor/LibffiAdjustor.c
index 2d128b78b279..1c4721694b59 100644
--- a/rts/adjustor/LibffiAdjustor.c
+++ b/rts/adjustor/LibffiAdjustor.c
@@ -145,8 +145,7 @@ static ffi_type * char_to_ffi_type(char c)
}
void*
-createAdjustor (int cconv,
- StgStablePtr hptr,
+createAdjustor (StgStablePtr hptr,
StgFunPtr wptr,
char *typeString)
{
@@ -155,7 +154,7 @@ createAdjustor (int cconv,
uint32_t n_args, i;
ffi_type *result_type;
ffi_closure *cl;
- int r, abi;
+ int r;
void *code;
n_args = strlen(typeString) - 1;
@@ -166,20 +165,8 @@ createAdjustor (int cconv,
for (i=0; i < n_args; i++) {
arg_types[i] = char_to_ffi_type(typeString[i+1]);
}
- switch (cconv) {
-#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
- case 0: /* stdcall */
- abi = FFI_STDCALL;
- break;
-#endif /* defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) */
- case 1: /* ccall */
- abi = FFI_DEFAULT_ABI;
- break;
- default:
- barf("createAdjustor: convention %d not supported on this platform", cconv);
- }
- r = ffi_prep_cif(cif, abi, n_args, result_type, arg_types);
+ r = ffi_prep_cif(cif, FFI_DEFAULT_ABI, n_args, result_type, arg_types);
if (r != FFI_OK) barf("ffi_prep_cif failed: %d", r);
cl = allocate_adjustor(&code, cif, wptr, hptr);
diff --git a/rts/adjustor/NativeAmd64.c b/rts/adjustor/NativeAmd64.c
index 086a8533622b..6bffe3fed121 100644
--- a/rts/adjustor/NativeAmd64.c
+++ b/rts/adjustor/NativeAmd64.c
@@ -35,7 +35,7 @@ void initAdjustors(void)
}
void*
-createAdjustor(int cconv, StgStablePtr hptr,
+createAdjustor(StgStablePtr hptr,
StgFunPtr wptr,
char *typeString
)
@@ -45,9 +45,6 @@ createAdjustor(int cconv, StgStablePtr hptr,
.wptr = wptr,
};
- switch (cconv)
- {
- case 1: /* _ccall */
/*
stack at call:
argn
@@ -75,7 +72,6 @@ createAdjustor(int cconv, StgStablePtr hptr,
pointer inserted just after the 6th integer argument.
*/
- {
int n_int_args = 0;
// determine whether we have 6 or more integer arguments,
@@ -94,13 +90,6 @@ createAdjustor(int cconv, StgStablePtr hptr,
} else {
return alloc_adjustor(complex_ccall_pool, &context);
}
- break;
- }
-
- default:
- barf("createAdjustor: Unsupported calling convention");
- break;
- }
}
void freeHaskellFunctionPtr(void* ptr)
diff --git a/rts/adjustor/NativeAmd64Mingw.c b/rts/adjustor/NativeAmd64Mingw.c
index 4e3c305d66cd..3635e7adc9d8 100644
--- a/rts/adjustor/NativeAmd64Mingw.c
+++ b/rts/adjustor/NativeAmd64Mingw.c
@@ -42,7 +42,7 @@ void initAdjustors(void)
}
void*
-createAdjustor(int cconv, StgStablePtr hptr,
+createAdjustor(StgStablePtr hptr,
StgFunPtr wptr,
char *typeString
)
@@ -52,9 +52,6 @@ createAdjustor(int cconv, StgStablePtr hptr,
.wptr = wptr,
};
- switch (cconv)
- {
- case 1: /* _ccall */
/*
stack at call:
argn
@@ -83,7 +80,6 @@ createAdjustor(int cconv, StgStablePtr hptr,
See NativeAmd64MingwAsm.S.
*/
- {
// determine whether we have 4 or more integer arguments,
// and therefore need to flush one to the stack.
if ((typeString[0] == '\0') ||
@@ -102,12 +98,6 @@ createAdjustor(int cconv, StgStablePtr hptr,
return alloc_adjustor(complex_nofloat_ccall_pool, &context);
}
}
- }
-
- default:
- barf("createAdjustor: Unsupported calling convention");
- break;
- }
}
void freeHaskellFunctionPtr(void* ptr)
@@ -116,4 +106,3 @@ void freeHaskellFunctionPtr(void* ptr)
free_adjustor(ptr, &context);
freeStablePtr(context.hptr);
}
-
diff --git a/rts/adjustor/NativeIA64.c b/rts/adjustor/NativeIA64.c
index 2fe40ce56679..79695a04e2e6 100644
--- a/rts/adjustor/NativeIA64.c
+++ b/rts/adjustor/NativeIA64.c
@@ -38,7 +38,7 @@ stgAllocStable(size_t size_in_bytes, StgStablePtr *stable)
void initAdjustors(void) { }
void*
-createAdjustor(int cconv, StgStablePtr hptr,
+createAdjustor(StgStablePtr hptr,
StgFunPtr wptr,
char *typeString
#if !defined(powerpc_HOST_ARCH) && !defined(powerpc64_HOST_ARCH) && !defined(x86_64_HOST_ARCH)
@@ -49,9 +49,6 @@ createAdjustor(int cconv, StgStablePtr hptr,
void *adjustor = NULL;
void *code = NULL;
- switch (cconv)
- {
- case 1: /* _ccall */
/*
Up to 8 inputs are passed in registers. We flush the last two inputs to
the stack, initially into the 16-byte scratch region left by the caller.
@@ -98,7 +95,6 @@ createAdjustor(int cconv, StgStablePtr hptr,
| (BITS(val,40,23)) \
| (BITS(val,63,1) << 59))
- {
StgStablePtr stable;
IA64FunDesc *wdesc = (IA64FunDesc *)wptr;
StgWord64 wcode = wdesc->ip;
@@ -139,15 +135,6 @@ createAdjustor(int cconv, StgStablePtr hptr,
/* save stable pointers in convenient form */
code[16] = (StgWord64)hptr;
code[17] = (StgWord64)stable;
- }
-#else
- barf("adjustor creation not supported on this platform");
-#endif
- break;
-
- default:
- barf("createAdjustor: Unsupported calling convention");
- }
return code;
}
diff --git a/rts/adjustor/NativePowerPC.c b/rts/adjustor/NativePowerPC.c
index 7ad32fb7608b..8dc435f8f564 100644
--- a/rts/adjustor/NativePowerPC.c
+++ b/rts/adjustor/NativePowerPC.c
@@ -54,19 +54,15 @@ typedef struct AdjustorStub {
void initAdjustors(void) { }
void*
-createAdjustor(int cconv, StgStablePtr hptr,
+createAdjustor(StgStablePtr hptr,
StgFunPtr wptr,
char *typeString
)
{
- switch (cconv)
- {
- case 1: /* _ccall */
#if defined(linux_HOST_OS)
#define OP_LO(op,lo) ((((unsigned)(op)) << 16) | (((unsigned)(lo)) & 0xFFFF))
#define OP_HI(op,hi) ((((unsigned)(op)) << 16) | (((unsigned)(hi)) >> 16))
- {
/* The PowerPC Linux (32-bit) calling convention is annoyingly complex.
We need to calculate all the details of the stack frame layout,
taking into account the types of all the arguments, and then
@@ -273,13 +269,11 @@ createAdjustor(int cconv, StgStablePtr hptr,
}
__asm__ volatile ("sync\n\tisync");
}
- }
#else
#define OP_LO(op,lo) ((((unsigned)(op)) << 16) | (((unsigned)(lo)) & 0xFFFF))
#define OP_HI(op,hi) ((((unsigned)(op)) << 16) | (((unsigned)(hi)) >> 16))
- {
/* The following code applies to all PowerPC and PowerPC64 platforms
whose stack layout is based on the AIX ABI.
@@ -384,11 +378,6 @@ createAdjustor(int cconv, StgStablePtr hptr,
adjustorStub->extrawords_plus_one = extra_sz + 1;
return code;
- }
-
- default:
- barf("createAdjustor: Unsupported calling convention");
- }
}
void
diff --git a/rts/adjustor/Nativei386.c b/rts/adjustor/Nativei386.c
index 22db4fa4ca15..dfdd045343f1 100644
--- a/rts/adjustor/Nativei386.c
+++ b/rts/adjustor/Nativei386.c
@@ -54,73 +54,15 @@ static void mk_ccall_adjustor(uint8_t *code, const void *context, void *user_dat
/* adjustors to handle ccalls */
static struct AdjustorPool *ccall_pool;
-/***************************************
- * stdcall adjustor
- ***************************************/
-
-#if !defined(darwin_HOST_OS)
-#define STDCALL_ADJUSTOR_LEN 0x0c
-
-static void mk_stdcall_adjustor(uint8_t *code, const void *context, void *user_data STG_UNUSED)
-{
- /* Magic constant computed by inspecting the code length of
- the following assembly language snippet
- (offset and machine code prefixed):
-
- <0>: 58 popl %eax # temp. remove return addr.
- <1>: b9 fd fc fe fa movl 0xfafefcfd, %ecx # constant is addr. of AdjustorContext
- <6>: ff 31 pushl (%ecx) # push hptr
- <8>: 50 pushl %eax # put back return addr.
- <9>: ff 61 04 jmp *4(%ecx) # and jump to wptr
- # the callee cleans up the stack
- */
- code[0x00] = 0x58; /* popl %eax */
-
- code[0x01] = 0xb9; /* movl context (which is a dword immediate), %ecx */
- *((const void **) &(code[0x02])) = context;
-
- code[0x06] = 0xff; /* pushl (%ecx) */
- code[0x07] = 0x31;
-
- code[0x08] = 0x50; /* pushl %eax */
-
- code[0x09] = 0xff; /* jmp *4(%ecx) */
- code[0x0a] = 0x61;
- code[0x0b] = 0x04;
-}
-
-static struct AdjustorPool *stdcall_pool;
-#endif
-
void initAdjustors(void) {
ccall_pool = new_adjustor_pool(sizeof(struct CCallContext), CCALL_ADJUSTOR_LEN, mk_ccall_adjustor, NULL);
-#if !defined(darwin_HOST_OS)
- stdcall_pool = new_adjustor_pool(sizeof(struct AdjustorContext), STDCALL_ADJUSTOR_LEN, mk_stdcall_adjustor, NULL);
-#endif
}
void*
-createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr,
+createAdjustor(StgStablePtr hptr, StgFunPtr wptr,
char *typeString STG_UNUSED
)
{
-
- switch (cconv)
- {
- case 0: { /* _stdcall */
-#if defined(darwin_HOST_OS)
- barf("stdcall is not supported on Darwin")
-#else
- struct AdjustorContext context = {
- .hptr = hptr,
- .wptr = wptr,
- };
- return alloc_adjustor(stdcall_pool, &context);
-#endif /* !defined(darwin_HOST_OS) */
- }
-
- case 1: /* _ccall */
- {
// The adjustor puts the following things on the stack:
// 1.) %ebp link
// 2.) padding and (a copy of) the arguments
@@ -144,11 +86,6 @@ createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr,
.argument_size = sz,
};
return alloc_adjustor(ccall_pool, &context);
- }
-
- default:
- barf("createAdjustor: Unsupported calling convention");
- }
}
void
diff --git a/rts/include/rts/Adjustor.h b/rts/include/rts/Adjustor.h
index 8965c7c8bb03..8426863a6396 100644
--- a/rts/include/rts/Adjustor.h
+++ b/rts/include/rts/Adjustor.h
@@ -14,8 +14,7 @@
#pragma once
/* Creating and destroying an adjustor thunk */
-void* createAdjustor (int cconv,
- StgStablePtr hptr,
+void* createAdjustor (StgStablePtr hptr,
StgFunPtr wptr,
char *typeString);
diff --git a/rts/include/rts/OSThreads.h b/rts/include/rts/OSThreads.h
index 8ffb25fabf9f..9809da1f8c05 100644
--- a/rts/include/rts/OSThreads.h
+++ b/rts/include/rts/OSThreads.h
@@ -91,8 +91,8 @@ EXTERN_INLINE int OS_TRY_ACQUIRE_LOCK(pthread_mutex_t *mutex)
/* We jump through a hoop here to get a CCall AcquireSRWLockExclusive
and ReleaseSRWLockExclusive, as that's what C-- wants. */
-#define OS_ACQUIRE_LOCK(mutex) foreign "stdcall" AcquireSRWLockExclusive(mutex)
-#define OS_RELEASE_LOCK(mutex) foreign "stdcall" ReleaseSRWLockExclusive(mutex)
+#define OS_ACQUIRE_LOCK(mutex) ccall AcquireSRWLockExclusive((mutex) "ptr")
+#define OS_RELEASE_LOCK(mutex) ccall ReleaseSRWLockExclusive((mutex) "ptr")
#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */
#else // CMINUSMINUS
@@ -109,7 +109,7 @@ typedef DWORD OSThreadId;
// many HANDLES to a given thread, so comparison would not work.
typedef DWORD ThreadLocalKey;
-#define OSThreadProcAttr __stdcall
+#define OSThreadProcAttr
#define INIT_COND_VAR 0
diff --git a/rts/js/mem.js b/rts/js/mem.js
index 3baf27ef759c..c6dd2c14e442 100644
--- a/rts/js/mem.js
+++ b/rts/js/mem.js
@@ -1271,7 +1271,7 @@ function h$addExtraRoot() {
// fixme
}
-function h$createAdjustor(cconv, stbl_d, stbl_o, lbl_d, lbl_o, typeStr_d, typeStr_o) {
+function h$createAdjustor(stbl_d, stbl_o, lbl_d, lbl_o, typeStr_d, typeStr_o) {
// fixme shouldn't we just use stablePtr for this?
var func = lbl_d.arr[lbl_o];
// var typeStr = h$decodeUtf8z(typeStr_d, typeStr_o);
diff --git a/rts/linker/PEi386.c b/rts/linker/PEi386.c
index 34acf463e87a..0b205f9d6e73 100644
--- a/rts/linker/PEi386.c
+++ b/rts/linker/PEi386.c
@@ -1131,7 +1131,6 @@ get_name_string (uint8_t* name, ObjectCode* oc)
}
}
-/* See Note [mingw-w64 name decoration scheme] */
#if !defined(x86_64_HOST_ARCH)
static void
zapTrailingAtSign ( SymbolName* sym )
@@ -1160,9 +1159,9 @@ lookupSymbolInDLL_PEi386 ( const SymbolName* lbl, HINSTANCE instance, pathchar*
/* debugBelch("look in %ls for %s\n", dll_name, lbl); */
- sym = GetProcAddress(instance, lbl+STRIP_LEADING_UNDERSCORE);
+ sym = GetProcAddress(instance, lbl);
if (sym != NULL) {
- /*debugBelch("found %s in %ls\n", lbl+STRIP_LEADING_UNDERSCORE,dll_name);*/
+ /*debugBelch("found %s in %ls\n", lbl, dll_name);*/
return sym;
}
@@ -1176,7 +1175,7 @@ lookupSymbolInDLL_PEi386 ( const SymbolName* lbl, HINSTANCE instance, pathchar*
*/
if (sym == NULL && strncmp (lbl, "__imp_", 6) == 0) {
sym = GetProcAddress(instance,
- lbl + 6 + STRIP_LEADING_UNDERSCORE);
+ lbl + 6);
if (sym != NULL) {
SymbolAddr** indirect = m32_alloc(dependent->rw_m32, sizeof(SymbolAddr*), 8);
if (indirect == NULL) {
@@ -1185,7 +1184,7 @@ lookupSymbolInDLL_PEi386 ( const SymbolName* lbl, HINSTANCE instance, pathchar*
*indirect = sym;
IF_DEBUG(linker,
debugBelch("warning: %s from %S is linked instead of %s\n",
- lbl+6+STRIP_LEADING_UNDERSCORE, dll_name, lbl));
+ lbl+6, dll_name, lbl));
return (void*) indirect;
}
}
@@ -2326,7 +2325,6 @@ SymbolAddr *lookupSymbol_PEi386(SymbolName *lbl, ObjectCode *dependent, SymType
SymbolAddr* sym;
-/* See Note [mingw-w64 name decoration scheme] */
#if !defined(x86_64_HOST_ARCH)
zapTrailingAtSign ( lbl );
#endif
diff --git a/rts/linker/PEi386.h b/rts/linker/PEi386.h
index 384c50aee3d8..b1453c5d804a 100644
--- a/rts/linker/PEi386.h
+++ b/rts/linker/PEi386.h
@@ -62,7 +62,6 @@ bool ocVerifyImage_PEi386 ( ObjectCode* oc );
SymbolAddr *lookupSymbol_PEi386(SymbolName *lbl, ObjectCode *dependent, SymType *type);
SymbolAddr *lookupSymbolInDLL_PEi386 (const SymbolName* lbl, HINSTANCE instance, pathchar* dll_name, ObjectCode *dependent);
-/* See Note [mingw-w64 name decoration scheme] */
/* We use myindex to calculate array addresses, rather than
simply doing the normal subscript thing. That's because
some of the above structs have sizes which are not
@@ -151,27 +150,4 @@ uint8_t getSymNumberOfAuxSymbols ( COFF_HEADER_INFO *info, COFF_symbol* sym );
uint16_t getSymType ( COFF_HEADER_INFO *info, COFF_symbol* sym );
uint8_t* getSymShortName ( COFF_HEADER_INFO *info, COFF_symbol* sym );
-/* See Note [mingw-w64 name decoration scheme] */
-#if !defined(x86_64_HOST_ARCH)
-#define STRIP_LEADING_UNDERSCORE 1
-#else
-#define STRIP_LEADING_UNDERSCORE 0
-#endif
-
-/*
-Note [mingw-w64 name decoration scheme]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What's going on with name decoration? Well, original code
-have some crufty and ad-hocish paths related mostly to very old
-mingw gcc/binutils/runtime combinations. Now mingw-w64 offers pretty
-uniform and MS-compatible decoration scheme across its tools and runtime.
-
-The scheme is pretty straightforward: on 32 bit objects symbols are exported
-with underscore prepended (and @ + stack size suffix appended for stdcall
-functions), on 64 bits no underscore is prepended and no suffix is appended
-because we have no stdcall convention on 64 bits.
-
-See #9218
-*/
-
#include "EndPrivate.h"
diff --git a/rts/win32/OSThreads.c b/rts/win32/OSThreads.c
index 2d2c59fa3083..ab63b677f286 100644
--- a/rts/win32/OSThreads.c
+++ b/rts/win32/OSThreads.c
@@ -137,7 +137,7 @@ freeThreadLocalKey (ThreadLocalKey *key)
}
-static unsigned __stdcall
+static unsigned
forkOS_createThreadWrapper ( void * entry )
{
Capability *cap;
--
GitLab