From 497302c44ad08c6c27d0e15d94a787f332c0cfec Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Fri, 6 Feb 2009 14:02:49 +0000 Subject: [PATCH] When generating C, don't pretend functions are data We used to generated things like: extern StgWordArray (newCAF) __attribute__((aligned (8))); ((void (*)(void *))(W_)&newCAF)((void *)R1.w); (which is to say, pretend that newCAF is some data, then cast it to a function and call it). This goes wrong on at least IA64, where: A function pointer on the ia64 does not point to the first byte of code. Intsead, it points to a structure that describes the function. The first quadword in the structure is the address of the first byte of code so we end up dereferencing function pointers one time too many, and segfaulting. --- compiler/basicTypes/BasicTypes.lhs | 17 +++++++++++ compiler/basicTypes/Literal.lhs | 38 ++++++++++++++---------- compiler/cmm/CLabel.hs | 39 ++++++++++++++----------- compiler/cmm/CmmParse.y | 5 ++-- compiler/cmm/PprC.hs | 31 +++++++++++--------- compiler/cmm/PprCmm.hs | 3 +- compiler/cmm/ZipCfgCmmRep.hs | 3 +- compiler/codeGen/CgForeignCall.hs | 3 +- compiler/codeGen/CgHpc.hs | 5 +++- compiler/codeGen/CgUtils.hs | 2 +- compiler/codeGen/StgCmmForeign.hs | 2 +- compiler/codeGen/StgCmmHpc.hs | 2 +- compiler/codeGen/StgCmmUtils.hs | 2 +- compiler/coreSyn/CoreUtils.lhs | 2 +- compiler/coreSyn/MkExternalCore.lhs | 2 +- compiler/deSugar/DsForeign.lhs | 9 ++++-- compiler/ghci/ByteCodeAsm.lhs | 4 +-- compiler/ghci/ByteCodeGen.lhs | 2 +- compiler/nativeGen/MachCodeGen.hs | 7 +++-- compiler/nativeGen/PositionIndependentCode.hs | 2 +- compiler/utils/Binary.hs | 11 +++++++ 21 files changed, 125 insertions(+), 66 deletions(-) diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 70a9312..04ed8fa 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -18,6 +18,8 @@ module BasicTypes( Version, bumpVersion, initialVersion, Arity, + + FunctionOrData(..), WarningTxt(..), @@ -72,6 +74,21 @@ import Outputable type Arity = Int \end{code} +%************************************************************************ +%* * +\subsection[FunctionOrData]{FunctionOrData} +%* * +%************************************************************************ + +\begin{code} +data FunctionOrData = IsFunction | IsData + deriving (Eq, Ord) + +instance Outputable FunctionOrData where + ppr IsFunction = text "(function)" + ppr IsData = text "(data)" +\end{code} + %************************************************************************ %* * diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs index 626f0cb..f2ea137 100644 --- a/compiler/basicTypes/Literal.lhs +++ b/compiler/basicTypes/Literal.lhs @@ -48,6 +48,7 @@ import Type import Outputable import FastTypes import FastString +import BasicTypes import Binary import Ratio @@ -121,11 +122,13 @@ data Literal | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble' | MachLabel FastString - (Maybe Int) -- ^ A label literal. Parameters: - -- - -- 1) The name of the symbol mentioned in the declaration - -- - -- 2) The size (in bytes) of the arguments + (Maybe Int) + 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@ => @\@ will -- be appended to label name when emitting assembly. @@ -144,7 +147,11 @@ instance Binary Literal where put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai - put_ bh (MachLabel aj mb) = do putByte bh 9; put_ bh aj ; put_ bh mb + put_ bh (MachLabel aj mb fod) + = do putByte bh 9 + put_ bh aj + put_ bh mb + put_ bh fod get bh = do h <- getByte bh case h of @@ -177,7 +184,8 @@ instance Binary Literal where 9 -> do aj <- get bh mb <- get bh - return (MachLabel aj mb) + fod <- get bh + return (MachLabel aj mb fod) \end{code} \begin{code} @@ -349,7 +357,7 @@ literalType (MachInt64 _) = int64PrimTy literalType (MachWord64 _) = word64PrimTy literalType (MachFloat _) = floatPrimTy literalType (MachDouble _) = doublePrimTy -literalType (MachLabel _ _) = addrPrimTy +literalType (MachLabel _ _ _) = addrPrimTy \end{code} @@ -366,7 +374,7 @@ cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b cmpLit (MachFloat a) (MachFloat b) = a `compare` b cmpLit (MachDouble a) (MachDouble b) = a `compare` b -cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b +cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT | otherwise = GT @@ -380,7 +388,7 @@ litTag (MachInt64 _) = _ILIT(6) litTag (MachWord64 _) = _ILIT(7) litTag (MachFloat _) = _ILIT(8) litTag (MachDouble _) = _ILIT(9) -litTag (MachLabel _ _) = _ILIT(10) +litTag (MachLabel _ _ _) = _ILIT(10) \end{code} Printing @@ -399,10 +407,10 @@ pprLit (MachWord64 w) = ptext (sLit "__word64") <+> integer w pprLit (MachFloat f) = ptext (sLit "__float") <+> rational f pprLit (MachDouble d) = rational d pprLit (MachNullAddr) = ptext (sLit "__NULL") -pprLit (MachLabel l mb) = ptext (sLit "__label") <+> - case mb of - Nothing -> pprHsString l - Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) +pprLit (MachLabel l mb fod) = ptext (sLit "__label") <+> b <+> ppr fod + where b = case mb of + Nothing -> pprHsString l + Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) pprIntVal :: Integer -> SDoc -- ^ Print negative integers with parens to be sure it's unambiguous @@ -431,7 +439,7 @@ hashLiteral (MachWord i) = hashInteger i hashLiteral (MachWord64 i) = hashInteger i hashLiteral (MachFloat r) = hashRational r hashLiteral (MachDouble r) = hashRational r -hashLiteral (MachLabel s _) = hashFS s +hashLiteral (MachLabel s _ _) = hashFS s hashRational :: Rational -> Int hashRational r = hashInteger (numerator r) diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index aa72b65..2501b6e 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -119,6 +119,8 @@ module CLabel ( import IdInfo import StaticFlags +import BasicTypes +import Literal import Packages import DataCon import PackageConfig @@ -193,11 +195,12 @@ data CLabel | RtsLabel RtsLabelInfo - | ForeignLabel FastString -- a 'C' (or otherwise foreign) 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. - Bool -- True <=> is dynamic + | ForeignLabel FastString -- a 'C' (or otherwise foreign) 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. + Bool -- True <=> is dynamic + FunctionOrData | CC_Label CostCentre | CCS_Label CostCentreStack @@ -373,17 +376,18 @@ mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) -- Foreign labels -mkForeignLabel :: FastString -> Maybe Int -> Bool -> CLabel -mkForeignLabel str mb_sz is_dynamic = ForeignLabel str mb_sz is_dynamic +mkForeignLabel :: FastString -> Maybe Int -> Bool -> FunctionOrData -> CLabel +mkForeignLabel str mb_sz is_dynamic fod + = ForeignLabel str mb_sz is_dynamic fod addLabelSize :: CLabel -> Int -> CLabel -addLabelSize (ForeignLabel str _ is_dynamic) sz - = ForeignLabel str (Just sz) is_dynamic +addLabelSize (ForeignLabel str _ is_dynamic fod) sz + = ForeignLabel str (Just sz) is_dynamic fod addLabelSize label _ = label foreignLabelStdcallInfo :: CLabel -> Maybe Int -foreignLabelStdcallInfo (ForeignLabel _ info _) = info +foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info foreignLabelStdcallInfo _lbl = Nothing -- Cost centres etc. @@ -498,7 +502,7 @@ needsCDecl ModuleRegdLabel = False needsCDecl (StringLitLabel _) = False needsCDecl (AsmTempLabel _) = False needsCDecl (RtsLabel _) = False -needsCDecl l@(ForeignLabel _ _ _) = not (isMathFun l) +needsCDecl l@(ForeignLabel _ _ _ _) = not (isMathFun l) needsCDecl (CC_Label _) = True needsCDecl (CCS_Label _) = True needsCDecl (HpcTicksLabel _) = True @@ -518,7 +522,7 @@ maybeAsmTemp _ = Nothing -- they are builtin to the C compiler. For these labels we avoid -- generating our own C prototypes. isMathFun :: CLabel -> Bool -isMathFun (ForeignLabel fs _ _) = fs `elem` math_funs +isMathFun (ForeignLabel fs _ _ _) = fs `elem` math_funs where math_funs = [ (fsLit "pow"), (fsLit "sin"), (fsLit "cos"), @@ -557,7 +561,7 @@ externallyVisibleCLabel (PlainModuleInitLabel _)= True externallyVisibleCLabel (ModuleInitTableLabel _)= False externallyVisibleCLabel ModuleRegdLabel = False externallyVisibleCLabel (RtsLabel _) = True -externallyVisibleCLabel (ForeignLabel _ _ _) = True +externallyVisibleCLabel (ForeignLabel _ _ _ _) = True externallyVisibleCLabel (IdLabel name _ _) = isExternalName name externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True @@ -611,6 +615,7 @@ labelType (PlainModuleInitLabel _) = CodeLabel labelType (ModuleInitTableLabel _) = DataLabel labelType (LargeSRTLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel +labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel labelType (IdLabel _ _ info) = idInfoLabelType info labelType _ = DataLabel @@ -639,11 +644,11 @@ labelDynamic this_pkg lbl = RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not? IdLabel n _ k -> isDllName this_pkg n #if mingw32_TARGET_OS - ForeignLabel _ _ d -> d + ForeignLabel _ _ d _ -> d #else -- On Mac OS X and on ELF platforms, false positives are OK, -- so we claim that all foreign imports come from dynamic libraries - ForeignLabel _ _ _ -> True + ForeignLabel _ _ _ _ -> True #endif ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m) PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m) @@ -738,7 +743,7 @@ maybe_underscore doc #ifdef mingw32_TARGET_OS -- In asm mode, we need to put the suffix on a stdcall ForeignLabel. -- (The C compiler does this itself). -pprAsmCLbl (ForeignLabel fs (Just sz) _) +pprAsmCLbl (ForeignLabel fs (Just sz) _ _) = ftext fs <> char '@' <> int sz #endif pprAsmCLbl lbl @@ -832,7 +837,7 @@ pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) pprCLbl ModuleRegdLabel = ptext (sLit "_module_registered") -pprCLbl (ForeignLabel str _ _) +pprCLbl (ForeignLabel str _ _ _) = ftext str pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 180aad6..e488a66 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -52,6 +52,7 @@ import FastString import Panic import Constants import Outputable +import BasicTypes import Bag ( emptyBag, unitBag ) import Control.Monad @@ -202,7 +203,7 @@ static :: { ExtFCode [CmmStatic] } | 'CLOSURE' '(' NAME lits ')' { do lits <- sequence $4; return $ map CmmStaticLit $ - mkStaticClosure (mkForeignLabel $3 Nothing True) + mkStaticClosure (mkForeignLabel $3 Nothing True IsFunction) -- mkForeignLabel because these are only used -- for CHARLIKE and INTLIKE closures in the RTS. dontCareCCS (map getLit lits) [] [] [] } @@ -824,7 +825,7 @@ newLocal ty name = do -- PIC code for them. newImport :: FastString -> ExtFCode () newImport name - = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True))) + = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True IsFunction))) newLabel :: FastString -> ExtFCode BlockId newLabel name = do diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 665122e..04aa9e9 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -49,6 +49,8 @@ import UniqFM import FastString import Outputable import Constants +import BasicTypes +import CLabel -- The rest import Data.List @@ -213,7 +215,7 @@ pprStmt stmt = case stmt of CmmCall (CmmCallee fn cconv) results args safety ret -> maybe_proto $$ - pprCall ppr_fn cconv results args safety + fnCall where cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn) @@ -221,7 +223,7 @@ pprStmt stmt = case stmt of pprCFunType (pprCLabel lbl) cconv results args <> noreturn_attr <> semi - data_proto lbl = ptext (sLit ";EI_(") <> + fun_proto lbl = ptext (sLit ";EF_(") <> pprCLabel lbl <> char ')' <> semi noreturn_attr = case ret of @@ -229,24 +231,27 @@ pprStmt stmt = case stmt of CmmMayReturn -> empty -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes - (maybe_proto, ppr_fn) = + (maybe_proto, fnCall) = case fn of CmmLit (CmmLabel lbl) - | StdCallConv <- cconv -> (real_fun_proto lbl, pprCLabel lbl) + | StdCallConv <- cconv -> + let myCall = pprCall (pprCLabel lbl) cconv results args safety + in (real_fun_proto lbl, myCall) -- 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 -> (real_fun_proto lbl, pprCLabel lbl) - | not (isMathFun lbl) -> (data_proto lbl, cast_fn) - -- we declare all other called functions as - -- data labels, and then cast them to the - -- right type when calling. This is because - -- the label might already have a declaration - -- as a data label in the same file, - -- e.g. Foreign.Marshal.Alloc declares 'free' - -- as both a data label and a function label. + | CmmNeverReturns <- ret -> + let myCall = pprCall (pprCLabel lbl) cconv results args safety + in (real_fun_proto lbl, myCall) + | not (isMathFun lbl) -> + let myCall = braces ( + pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi + $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi + $$ pprCall (text "ghcFunPtr") cconv results args safety <> semi + ) + in (fun_proto lbl, myCall) _ -> (empty {- no proto -}, cast_fn) -- for a dynamic call, no declaration is necessary. diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index a9e00fc..5040988 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -42,6 +42,7 @@ import BlockId import Cmm import CmmUtils import CLabel +import BasicTypes import ForeignCall @@ -275,7 +276,7 @@ pprStmt stmt = case stmt of pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) results args safety ret) where - lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False) + lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction) CmmBranch ident -> genBranch ident CmmCondBranch expr ident -> genCondBranch expr ident diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 43e310c..453b8f0 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -35,6 +35,7 @@ import ZipCfg import MkZipCfg import Util +import BasicTypes import Maybes import Monad import Outputable @@ -460,7 +461,7 @@ ppr_safety Unsafe = text "unsafe" ppr_call_target :: MidCallTarget -> SDoc ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn -ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)) +ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction)) ppr_target :: CmmExpr -> SDoc ppr_target t@(CmmLit _) = ppr t diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index ceff757..cf99f31 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -34,6 +34,7 @@ import Constants import StaticFlags import Outputable import FastString +import BasicTypes import Control.Monad @@ -77,7 +78,7 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live (call_args, cmm_target) = case target of StaticTarget lbl -> (args, CmmLit (CmmLabel - (mkForeignLabel lbl call_size False))) + (mkForeignLabel lbl call_size False IsFunction))) DynamicTarget -> case args of (CmmHinted fn _):rest -> (rest, fn) [] -> panic "emitForeignCall: DynamicTarget []" diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index 9ae5769..faee9c2 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -21,6 +21,9 @@ import FastString import HscTypes import Panic import Char +import StaticFlags +import BasicTypes +import PackageConfig import Data.Word @@ -66,7 +69,7 @@ initHpc this_mod (HpcInfo tickCount hashNo) PlayRisky [CmmHinted id NoHint] (CmmCallee - (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False) + (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False IsFunction) CCallConv ) [ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index b14d318..fad85f7 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -110,7 +110,7 @@ mkSimpleLit (MachWord i) = CmmInt i wordWidth mkSimpleLit (MachWord64 i) = CmmInt i W64 mkSimpleLit (MachFloat r) = CmmFloat r W32 mkSimpleLit (MachDouble r) = CmmFloat r W64 -mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn) +mkSimpleLit (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms is_dyn fod) where is_dyn = False -- ToDo: fix me diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index a4b5cf9..711b79e 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -58,7 +58,7 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a (call_args, cmm_target) = case target of StaticTarget lbl -> (args, CmmLit (CmmLabel - (mkForeignLabel lbl (call_size args) False))) + (mkForeignLabel lbl (call_size args) False IsFunction))) DynamicTarget -> case args of fn:rest -> (rest, fn) [] -> panic "cgForeignCall []" diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index f53c5c6..afc238a 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -54,7 +54,7 @@ initHpc this_mod (HpcInfo tickCount hashNo) ; id <- newTemp bWord -- TODO FIXME NOW ; emitCCall [(id,NoHint)] - (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False) + (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False IsFunction) [ (mkLblExpr mkHpcModuleNameLabel,AddrHint) , (CmmLit $ mkIntCLit tickCount,NoHint) , (CmmLit $ mkIntCLit hashNo,NoHint) diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 4803f5f..dc7fb8b 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -99,7 +99,7 @@ mkSimpleLit (MachWord i) = CmmInt i wordWidth mkSimpleLit (MachWord64 i) = CmmInt i W64 mkSimpleLit (MachFloat r) = CmmFloat r W32 mkSimpleLit (MachDouble r) = CmmFloat r W64 -mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn) +mkSimpleLit (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms is_dyn fod) where is_dyn = False -- ToDo: fix me mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other) diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 374c344..5d33b0f 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -1191,7 +1191,7 @@ rhsIsStatic _this_pkg rhs = is_static False rhs is_static _ (Lit lit) = case lit of - MachLabel _ _ -> False + MachLabel _ _ _ -> False _ -> True -- A MachLabel (foreign import "&foo") in an argument -- prevents a constructor application from being static. The diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 8273159..0cfb787 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -142,7 +142,7 @@ make_exp (Var v) = do DataConWorkId _ -> C.Var (make_var_qid False vName) DataConWrapId _ -> C.Var (make_var_qid False vName) _ -> C.Var (make_var_qid isLocal vName) -make_exp (Lit (MachLabel s _)) = return $ C.Label (unpackFS s) +make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s) make_exp (Lit l) = return $ C.Lit (make_lit l) make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t)) make_exp (App e1 e2) = do diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 080289e..0c40318 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -142,10 +142,15 @@ dsCImport :: Id -> DsM ([Binding], SDoc, SDoc) dsCImport id (CLabel cid) cconv _ = do let ty = idType id + fod = case splitTyConApp_maybe (repType ty) of + Just (tycon, _) + | tyConUnique tycon == funPtrTyConKey -> + IsFunction + _ -> IsData (resTy, foRhs) <- resultWrapper ty ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this let - rhs = foRhs (Lit (MachLabel cid stdcall_info)) + rhs = foRhs (Lit (MachLabel cid stdcall_info fod)) stdcall_info = fun_type_arg_stdcall_info cconv ty in return ([(id, rhs)], empty, empty) @@ -355,7 +360,7 @@ dsFExportDynamic id cconv = do -} adj_args = [ mkIntLitInt (ccallConvToInt cconv) , Var stbl_value - , Lit (MachLabel fe_nm mb_sz_args) + , Lit (MachLabel fe_nm mb_sz_args IsFunction) , Lit (mkMachString typestring) ] -- name of external entry point providing these services. diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index c6c7a0d..24fda15 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -377,12 +377,12 @@ mkBits findLabel st proto_insns return (sizeSS st_l0, (st_i0,st_l1,st_p0)) #ifdef mingw32_TARGET_OS - literal st (MachLabel fs (Just sz)) + literal st (MachLabel fs (Just sz) _) = litlabel st (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) #endif - literal st (MachLabel fs _) = litlabel st fs + literal st (MachLabel fs _ _) = litlabel st fs literal st (MachWord w) = int st (fromIntegral w) literal st (MachInt j) = int st (fromIntegral j) literal st MachNullAddr = int st (fromIntegral 0) diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index a9e3c07..95aae77 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -1205,7 +1205,7 @@ pushAtom d p (AnnVar v) pushAtom _ _ (AnnLit lit) = case lit of - MachLabel _ _ -> code NonPtrArg + MachLabel _ _ _ -> code NonPtrArg MachWord _ -> code NonPtrArg MachInt _ -> code PtrArg MachFloat _ -> code FloatArg diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index d16962c..d94a906 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -40,6 +40,7 @@ import CLabel import ClosureInfo ( C_SRT(..) ) -- The rest: +import BasicTypes import StaticFlags ( opt_PIC ) import ForeignCall ( CCallConv(..) ) import OrdList @@ -3408,7 +3409,7 @@ outOfLineFloatOp mop res args code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) return (code1 `appOL` code2) where - lbl = mkForeignLabel fn Nothing False + lbl = mkForeignLabel fn Nothing False IsFunction fn = case mop of MO_F32_Sqrt -> fsLit "sqrtf" @@ -3841,7 +3842,7 @@ outOfLineFloatOp mop dflags <- getDynFlagsNat mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference - $ mkForeignLabel functionName Nothing True + $ mkForeignLabel functionName Nothing True IsFunction let mopLabelOrExpr = case mopExpr of @@ -4112,7 +4113,7 @@ genCCall target dest_regs argsAndHints do dflags <- getDynFlagsNat mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ - mkForeignLabel functionName Nothing True + mkForeignLabel functionName Nothing True IsFunction let mopLabelOrExpr = case mopExpr of CmmLit (CmmLabel lbl) -> Left lbl _ -> Right mopExpr diff --git a/compiler/nativeGen/PositionIndependentCode.hs b/compiler/nativeGen/PositionIndependentCode.hs index 1635909..d74a627 100644 --- a/compiler/nativeGen/PositionIndependentCode.hs +++ b/compiler/nativeGen/PositionIndependentCode.hs @@ -525,7 +525,7 @@ needImportedSymbols = not opt_Static && not opt_PIC -- The label used to refer to our "fake GOT" from -- position-independent code. gotLabel = mkForeignLabel -- HACK: it's not really foreign - (fsLit ".LCTOC1") Nothing False + (fsLit ".LCTOC1") Nothing False IsData -- pprGotDeclaration -- Output whatever needs to be output once per .s file. diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 4f48a42..c61f8a6 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -67,6 +67,7 @@ import Panic import UniqFM import FastMutInt import Fingerprint +import BasicTypes import Foreign import Data.Array @@ -726,3 +727,13 @@ instance Binary Fingerprint where put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) +instance Binary FunctionOrData where + put_ bh IsFunction = putByte bh 0 + put_ bh IsData = putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> return IsFunction + 1 -> return IsData + _ -> panic "Binary FunctionOrData" + -- 1.7.10.4