diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs index 691766b8bce46841188468d9747ff9546f14ac2c..c2006a7c9f6750c0b464c82c1bee010eaf56f5d3 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 a8fa68415027630dc40301a39a09c2c54e5a2a4b..6eced164f3b82f9620d292e49bbfc51ac8d85b8c 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 1fe3f805f3467af1c2be0deff088f0c77f4ae821..1fbd581401c85180b359f9b99189aefcaac43d2f 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 365ede9f35dfda0d75314deb73a81908b98e438f..60b18ee984294ebaf4760a72ce4977fffeeb6b96 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 5dfedfe21d2eae477bb4a17b32018f9d524c230e..afc1273588f6630221495aff4b60af5b1de81506 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 fa68fedfede54fa73e40fbbccd96bb9d2bf6e9ab..9b642ea3cfff77f83ed31b89632a6ece3ec15079 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 5bda90ab455300789e8f4a16b74cd8a02006a22f..7a07a77c23c244d135086cf8de2c044c76ffe2bb 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 c95f62d37e86ed86f242c01aa2c1759d8682ec1d..cca47f7bac2fdbbd6e8765735968749240fb233a 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 1409e9b469418e2f3bc970c81a304fb111d99d00..c0264ee76ea213708350604031f7f7b62aa4bfb5 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 a8e060085447cebaac242d05a5a7cf2ec4611a56..cb5c6223f93a4c81a575d8220c2fed813c94e25c 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 44c8788c3feb3d3d2adbb564bf071f295b810a9c..a6cd5976429f7c0abe760cde395949c1e611ea10 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 8beaa8986ec594e3e98a65ee4d8ca430d8030f01..16918dd2af1170a02978ff0ffa8480806d4eeb05 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 7f5e9c975d8e58e79877aeb85f3930f0ef885bd8..27b70cef67c6bd336c52c2c0916bd7cde131887b 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 790d95fd4e945d2df56701ce8a84c4187e947bd0..77092ab89d8e02182659abaf1879517ae951a6f8 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 1e92ed7418a563c928c66b79cdd7203a76c40844..302b939e2626796944f081fd04b86d496d5fe5fb 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 a044c074ae999d6eac1522b094ecf34bae67830e..e587053992f1599ae3622318d2226c71ad79afd8 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 d12d73208922966f88b6a4aa7356717bf0ace207..b667008b83f539513d08e7f93ff7dcd0a1a60b33 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 7464eda718c2e27617d413220bd138eaef8cb994..e1f5a59a4dcb0e4b8769a809d50581d29b9652a5 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 f4815c56caf0935ee22ccbe986eb2a28dd8a29ba..53de40b712eae997597d7a14dffdf37ed3ecd861 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 b957b11b3e890384b8165ed99bc8283cfe8400c3..4d272fda6b5ee897d2b01978cdb943369d920e44 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 f967d9b8dd3565706a3431b67cfe239006deb6d9..74958983e88309bcefa0d96d6752ee8127092c67 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 a3f60e24363c652cac0e553b35e929820444a855..9157f7187408eb71ca04830ca422ef4d53297d54 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 e1870c50448501112130153dd76768f91a161116..a8019b396310402f78975dadba6201f35a71a39e 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 8cfa4805ac2a3c425553cb2c6bf24fe45fa5ba37..b99eb931a5389b7d897f090a0f6ff4f458767f4f 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 ce9718f9c24e93f0d1fdb601fc3f47b11c10d535..571fb4422fb4dd8f4ce7634d5c3816c935625741 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 5f9f4908a1f1a2063ded370a4bc4b5d515b36324..4af634ac6e9663d8b3734d7891ca146a3c267f16 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 301fb55ef62e2ba763f84dd13e68d01f44a6ff46..f88a7b0dd6784acb372c335941a58292dce78b84 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 09efb86cdbffee910c5f5db752f3ef42c599a4bf..fa211be8dec6f9704ccbefa0928b2571d684923e 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 26492af2d9eb3a05c91ef5ed3647a30f3584065f..815d1686bb80fedd02f4a7722dfaa7f3fdda46e6 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 2d128b78b279bf5b6ca7da87dabb4b7e07ff6a80..1c4721694b59f0f387c25de055d0c419dfcc718b 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 086a8533622b51b1dfc8b0012053f81bac5daa3c..6bffe3fed121c720a26c4f5b30051b17952a89d7 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 4e3c305d66cde359c620e136ec4e5903efb63726..3635e7adc9d8549b0a2fd838b5b27ff606cd04ac 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 2fe40ce5667999476e48049c5a9a9dddca44daca..79695a04e2e6984a74dff031916d87d8bc0e774a 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 7ad32fb7608b706f5c816e4bf155eb4b8526a027..8dc435f8f564e871d4138f2781df71427708f118 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 22db4fa4ca15944d6c0005a34235d53a7b1d661f..dfdd045343f122ad0f64f9f8418505d68deb1088 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 8965c7c8bb03db59b52586f7dcf0c4323bb477b0..8426863a63962d120a3a90849768c8a8a42ea396 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 8ffb25fabf9f62c8509f7f832bdf275e4b0241c2..9809da1f8c05b633a988b933a8d01d84aab87394 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 3baf27ef759cbbd0689cc92500df2d50aab5cf23..c6dd2c14e44263a61b39b5791415c265aba43d63 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 34acf463e87a6440f35e26f239fb23e9d80f8699..0b205f9d6e738624098ab2ebe9e8b5ecfd4da005 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 384c50aee3d839db2ef1345bc9ce8798239f7b87..b1453c5d804a8096d080e7cbff4a45f6a0c6ebf7 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 2d2c59fa30830df4bc10f5eb2956d94e0c02e920..ab63b677f286be53c7cd6c147544e39e19650ee9 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;