From: Ben.Lippmeier@anu.edu.au Date: Sat, 2 Jan 2010 05:37:54 +0000 (+0000) Subject: Tag ForeignCalls with the package they correspond to X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=7854ec4b11e117f8514553890851d14a66690fbb Tag ForeignCalls with the package they correspond to --- diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 614262c..4fd0d3a 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -15,6 +15,8 @@ module CLabel ( CLabel, -- abstract type + ForeignLabelSource(..), + pprDebugCLabel, mkClosureLabel, mkSRTLabel, @@ -175,12 +177,17 @@ data CLabel | RtsLabel RtsLabelInfo - -- | A 'C' (or otherwise foreign) label - | ForeignLabel FastString + -- | A 'C' (or otherwise foreign) label. + -- + | 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. - Bool -- True <=> is dynamic + + ForeignLabelSource -- what package the foreign label is in. + FunctionOrData -- | A family of labels related to a particular case expression. @@ -247,6 +254,52 @@ data CLabel deriving (Eq, Ord) + +-- | Record where a foreign label is stored. +data ForeignLabelSource + + -- | Label is in a named package + = ForeignLabelInPackage PackageId + + -- | Label is in some external, system package that doesn't also + -- contain compiled Haskell code, and is not associated with any .hi files. + -- We don't have to worry about Haskell code being inlined from + -- external packages. It is safe to treat the RTS package as "external". + | ForeignLabelInExternalPackage + + -- | Label is in the package currenly being compiled. + -- This is only used for creating hacky tmp labels during code generation. + -- Don't use it in any code that might be inlined across a package boundary + -- (ie, core code) else the information will be wrong relative to the + -- destination module. + | ForeignLabelInThisPackage + + deriving (Eq, Ord) + + +-- | For debugging problems with the CLabel representation. +-- We can't make a Show instance for CLabel because lots of its components don't have instances. +-- The regular Outputable instance only shows the label name, and not its other info. +-- +pprDebugCLabel :: CLabel -> SDoc +pprDebugCLabel lbl + = case lbl of + IdLabel{} -> ppr lbl <> (parens $ text "IdLabel") + CmmLabel pkg name _info + -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg) + + RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel") + + ForeignLabel name mSuffix src funOrData + -> ppr lbl <> (parens + $ text "ForeignLabel" + <+> ppr mSuffix + <+> ppr src + <+> ppr funOrData) + + _ -> ppr lbl <> (parens $ text "other CLabel)") + + data IdLabelInfo = Closure -- ^ Label for closure | SRT -- ^ Static reference table @@ -301,6 +354,7 @@ data CmmLabelInfo | CmmData -- ^ misc rts data bits, eg CHARLIKE_closure | CmmCode -- ^ misc rts code | CmmGcPtr -- ^ GcPtrs eg CHARLIKE_closure + | CmmPrimCall -- ^ a prim call to some hand written Cmm code deriving (Eq, Ord) data DynamicLinkerLabelInfo @@ -378,22 +432,34 @@ mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) --- Constructing ForeignLabels --- Primitive / cmm call labels +-- A call to some primitive hand written Cmm code mkPrimCallLabel :: PrimCall -> CLabel -mkPrimCallLabel (PrimCall str) = ForeignLabel str Nothing False IsFunction +mkPrimCallLabel (PrimCall str pkg) + = CmmLabel pkg str CmmPrimCall + --- Foreign labels -mkForeignLabel :: FastString -> Maybe Int -> Bool -> FunctionOrData -> CLabel -mkForeignLabel str mb_sz is_dynamic fod - = ForeignLabel str mb_sz is_dynamic fod +-- Constructing ForeignLabels +-- | Make a foreign label +mkForeignLabel + :: FastString -- name + -> Maybe Int -- size prefix + -> ForeignLabelSource -- what package it's in + -> FunctionOrData + -> CLabel + +mkForeignLabel str mb_sz src fod + = ForeignLabel str mb_sz src fod + + +-- | Update the label size field in a ForeignLabel addLabelSize :: CLabel -> Int -> CLabel -addLabelSize (ForeignLabel str _ is_dynamic fod) sz - = ForeignLabel str (Just sz) is_dynamic fod +addLabelSize (ForeignLabel str _ src fod) sz + = ForeignLabel str (Just sz) src fod addLabelSize label _ = label +-- | Get the label size field from a ForeignLabel foreignLabelStdcallInfo :: CLabel -> Maybe Int foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info foreignLabelStdcallInfo _lbl = Nothing @@ -530,8 +596,8 @@ needsCDecl ModuleRegdLabel = False needsCDecl (StringLitLabel _) = False needsCDecl (AsmTempLabel _) = False needsCDecl (RtsLabel _) = False -needsCDecl (CmmLabel _ _ _) = False -needsCDecl l@(ForeignLabel _ _ _ _) = not (isMathFun l) +needsCDecl (CmmLabel _ _ _) = True +needsCDecl l@(ForeignLabel{}) = not (isMathFun l) needsCDecl (CC_Label _) = True needsCDecl (CCS_Label _) = True needsCDecl (HpcTicksLabel _) = True @@ -551,12 +617,12 @@ maybeAsmTemp (AsmTempLabel uq) = Just uq maybeAsmTemp _ = Nothing --- Check whether a label corresponds to a C function that has +-- | Check whether a label corresponds to a C function that has -- a prototype in a system header somehere, or is built-in -- to the C compiler. For these labels we abovoid 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 = mkUniqSet [ @@ -640,12 +706,10 @@ math_funs = mkUniqSet [ ] -- ----------------------------------------------------------------------------- --- Is a CLabel visible outside this object file or not? - --- From the point of view of the code generator, a name is --- externally visible if it has to be declared as exported --- in the .o file's symbol table; that is, made non-static. - +-- | Is a CLabel visible outside this object file or not? +-- From the point of view of the code generator, a name is +-- externally visible if it has to be declared as exported +-- in the .o file's symbol table; that is, made non-static. externallyVisibleCLabel :: CLabel -> Bool -- not C "static" externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (StringLitLabel _) = False @@ -656,7 +720,7 @@ externallyVisibleCLabel (ModuleInitTableLabel _)= False externallyVisibleCLabel ModuleRegdLabel = False externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (CmmLabel _ _ _) = True -externallyVisibleCLabel (ForeignLabel _ _ _ _) = True +externallyVisibleCLabel (ForeignLabel{}) = True externallyVisibleCLabel (IdLabel name _ _) = isExternalName name externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True @@ -707,7 +771,7 @@ labelType (PlainModuleInitLabel _) = CodeLabel labelType (ModuleInitTableLabel _) = DataLabel labelType (LargeSRTLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel -labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel +labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel labelType (IdLabel _ _ info) = idInfoLabelType info labelType _ = DataLabel @@ -733,15 +797,32 @@ idInfoLabelType info = labelDynamic :: PackageId -> CLabel -> Bool labelDynamic this_pkg lbl = case lbl of - RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not? - CmmLabel pkg _ _ -> not opt_Static && (this_pkg /= pkg) + -- is the RTS in a DLL or not? + RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) + + -- When compiling in the "dyn" way, eack package is to be linked into its own shared library. + CmmLabel pkg _ _ + -> not opt_Static && (this_pkg /= pkg) + IdLabel n _ k -> isDllName this_pkg n + #if mingw32_TARGET_OS - ForeignLabel _ _ d _ -> d + -- Foreign label is in some un-named foreign package (or DLL) + ForeignLabel _ _ ForeignLabelInExternalPackage _ -> True + + -- Foreign label is linked into the same package as the source file currently being compiled. + ForeignLabel _ _ ForeignLabelInThisPackage _ -> False + + -- Foreign label is in some named package. + -- When compiling in the "dyn" way, each package is to be linked into its own DLL. + ForeignLabel _ _ (ForeignLabelInPackage pkgId) _ + -> (not opt_Static) && (this_pkg /= pkgId) + #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 + #endif ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m) PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m) @@ -864,6 +945,7 @@ pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLi pprCLbl (CmmLabel _ str CmmCode) = ftext str pprCLbl (CmmLabel _ str CmmData) = ftext str pprCLbl (CmmLabel _ str CmmGcPtr) = ftext str +pprCLbl (CmmLabel _ str CmmPrimCall) = ftext str pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> ptext (sLit "_fast") @@ -959,6 +1041,14 @@ ppIdFlavor x = pp_cSEP <> pp_cSEP = char '_' + +instance Outputable ForeignLabelSource where + ppr fs + = case fs of + ForeignLabelInPackage pkgId -> parens $ text "package: " <> ppr pkgId + ForeignLabelInThisPackage -> parens $ text "this package" + ForeignLabelInExternalPackage -> parens $ text "external package" + -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index ff6358d..0ae88e2 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -214,7 +214,7 @@ static :: { ExtFCode [CmmStatic] } | 'CLOSURE' '(' NAME lits ')' { do lits <- sequence $4; return $ map CmmStaticLit $ - mkStaticClosure (mkForeignLabel $3 Nothing True IsData) + mkStaticClosure (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) -- mkForeignLabel because these are only used -- for CHARLIKE and INTLIKE closures in the RTS. dontCareCCS (map getLit lits) [] [] [] } @@ -346,14 +346,21 @@ decl :: { ExtCode } -- an imported function name, with optional packageId importNames - :: { [(Maybe PackageId, FastString)] } + :: { [(FastString, CLabel)] } : importName { [$1] } | importName ',' importNames { $1 : $3 } importName - :: { (Maybe PackageId, FastString) } - : NAME { (Nothing, $1) } - | STRING NAME { (Just (fsToPackageId (mkFastString $1)), $2) } + :: { (FastString, CLabel) } + + -- A label imported without an explicit packageId. + -- These are taken to come frome some foreign, unnamed package. + : NAME + { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) } + + -- A label imported with an explicit packageId. + | STRING NAME + { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) } names :: { [FastString] } diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index d8d34c3..1160273 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -272,11 +272,16 @@ pprStmt stmt = case stmt of CmmCallConv -> empty _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) + -- Call a CallishMachOp, like sin or cos that might be implemented as a library call. CmmCall (CmmPrim op) results args safety ret -> pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) results args safety ret) where - lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction) + -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we + -- use one to get the label printed. + lbl = CmmLabel (mkForeignLabel + (mkFastString (show op)) + Nothing ForeignLabelInThisPackage IsFunction) CmmBranch ident -> genBranch ident CmmCondBranch expr ident -> genCondBranch expr ident diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 9aae097..0a494f8 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -484,8 +484,12 @@ 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 IsFunction)) +ppr_call_target (PrimTarget op) + -- HACK: We're just using a ForeignLabel to get this printed, the label + -- might not really be foreign. + = ppr (CmmLabel (mkForeignLabel + (mkFastString (show op)) + Nothing ForeignLabelInThisPackage IsFunction)) ppr_target :: CmmExpr -> SDoc ppr_target t@(CmmLit _) = ppr t diff --git a/compiler/codeGen/CgExtCode.hs b/compiler/codeGen/CgExtCode.hs index 03ac75e..0e0a802 100644 --- a/compiler/codeGen/CgExtCode.hs +++ b/compiler/codeGen/CgExtCode.hs @@ -21,7 +21,6 @@ module CgExtCode ( newLabel, newFunctionName, newImport, - lookupLabel, lookupName, @@ -42,7 +41,7 @@ import CgMonad import CLabel import Cmm -import BasicTypes +-- import BasicTypes import BlockId import FastString import Module @@ -146,14 +145,13 @@ newFunctionName name pkg -- | Add an imported foreign label to the list of local declarations. -- If this is done at the start of the module the declaration will scope -- over the whole module. --- CLabel's labelDynamic classifies these labels as dynamic, hence the --- code generator emits PIC code for them. -newImport :: (Maybe PackageId, FastString) -> ExtFCode () -newImport (Nothing, name) - = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True IsFunction))) - -newImport (Just pkg, name) - = addVarDecl name (CmmLit (CmmLabel (mkCmmCodeLabel pkg name))) +newImport + :: (FastString, CLabel) + -> ExtFCode () + +newImport (name, cmmLabel) + = addVarDecl name (CmmLit (CmmLabel cmmLabel)) + -- | Lookup the BlockId bound to the label with this name. -- If one hasn't been bound yet, create a fresh one based on the diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 809e10b..879d043 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -78,8 +78,27 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live where (call_args, cmm_target) = case target of - StaticTarget lbl -> (args, CmmLit (CmmLabel - (mkForeignLabel lbl call_size False IsFunction))) + + -- A target label known to be in the current package. + StaticTarget lbl + -> ( args + , CmmLit (CmmLabel + (mkForeignLabel lbl call_size ForeignLabelInThisPackage IsFunction))) + + -- If the packageId is Nothing then the label is taken to be in the + -- package currently being compiled. + PackageTarget lbl mPkgId + -> let labelSource + = case mPkgId of + Nothing -> ForeignLabelInThisPackage + Just pkgId -> ForeignLabelInPackage pkgId + in ( args + , CmmLit (CmmLabel + (mkForeignLabel lbl call_size labelSource IsFunction))) + + -- A label imported with "foreign import ccall "dynamic" ..." + -- Note: "dynamic" here doesn't mean "dynamic library". + -- Read the FFI spec for details. 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 c66af03..3d300ed 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -67,7 +67,7 @@ initHpc this_mod (HpcInfo tickCount hashNo) PlayRisky [CmmHinted id NoHint] (CmmCallee - (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False IsFunction) + (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage IsFunction) CCallConv ) [ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 75f6b19..8ce1ffc 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -111,9 +111,11 @@ 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 fod) = CmmLabel (mkForeignLabel fs ms is_dyn fod) - where - is_dyn = False -- ToDo: fix me +mkSimpleLit (MachLabel fs ms fod) + = CmmLabel (mkForeignLabel fs ms labelSrc fod) + where + -- TODO: Literal labels might not actually be in the current package... + labelSrc = ForeignLabelInThisPackage mkLtOp :: Literal -> MachOp -- On signed literals we must do a signed comparison diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 89a2b27..bda9e0f 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -59,7 +59,7 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a StaticTarget lbl -> (unzip cmm_args, CmmLit (CmmLabel (mkForeignLabel lbl (call_size cmm_args) - False IsFunction))) + ForeignLabelInThisPackage IsFunction))) DynamicTarget -> case cmm_args of (fn,_):rest -> (unzip rest, fn) [] -> panic "cgForeignCall []" diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index e78acb7..8bf1fbf 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -55,7 +55,7 @@ initHpc this_mod (HpcInfo tickCount hashNo) ; id <- newTemp bWord -- TODO FIXME NOW ; emitCCall [(id,NoHint)] - (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False IsFunction) + (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage 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 73b3052..9cfb241 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -98,9 +98,11 @@ 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 fod) = CmmLabel (mkForeignLabel fs ms is_dyn fod) - where - is_dyn = False -- ToDo: fix me +mkSimpleLit (MachLabel fs ms fod) + = CmmLabel (mkForeignLabel fs ms labelSrc fod) + where + -- TODO: Literal labels might not actually be in the current package... + labelSrc = ForeignLabelInThisPackage mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other) mkLtOp :: Literal -> MachOp diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index d57ca18..56242b7 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -407,7 +407,14 @@ way_details = Way WayDyn "dyn" False "Dynamic" [ "-DDYNAMIC" - , "-optc-DDYNAMIC" ], + , "-optc-DDYNAMIC" +#if defined(mingw32_TARGET_OS) + -- On Windows, code that is to be linked into a dynamic library must be compiled + -- with -fPIC. Labels not in the current package are assumed to be in a DLL + -- different from the current one. + , "-fPIC" +#endif + ], Way WayProf "p" False "Profiling" [ "-fscc-profiling" diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index eb233e0..a573b6b 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -64,12 +64,12 @@ import NCGMonad import Cmm -import CLabel ( CLabel, pprCLabel, +import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..), dynamicLinkerLabelInfo, mkPicBaseLabel, labelDynamic, externallyVisibleCLabel ) -import CLabel ( mkForeignLabel ) +import CLabel ( mkForeignLabel, pprDebugCLabel ) import StaticFlags ( opt_PIC, opt_Static ) @@ -83,6 +83,7 @@ import DynFlags import FastString + -------------------------------------------------------------------------------- -- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm -- code. It does The Right Thing(tm) to convert the CmmLabel into a @@ -110,8 +111,12 @@ cmmMakeDynamicReference -> ReferenceKind -- whether this is the target of a jump -> CLabel -- the label -> m CmmExpr - + cmmMakeDynamicReference dflags addImport referenceKind lbl + = cmmMakeDynamicReference' dflags addImport referenceKind lbl + + +cmmMakeDynamicReference' dflags addImport referenceKind lbl | Just _ <- dynamicLinkerLabelInfo lbl = return $ CmmLit $ CmmLabel lbl -- already processed it, pass through @@ -450,8 +455,10 @@ needImportedSymbols arch os -- position-independent code. gotLabel :: CLabel gotLabel - = mkForeignLabel -- HACK: it's not really foreign - (fsLit ".LCTOC1") Nothing False IsData + -- HACK: this label isn't really foreign + = mkForeignLabel + (fsLit ".LCTOC1") + Nothing ForeignLabelInThisPackage IsData diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs index be78972..71d3188 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CCall.hs @@ -263,7 +263,7 @@ outOfLineFloatOp mop dflags <- getDynFlagsNat mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference - $ mkForeignLabel functionName Nothing True IsFunction + $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction let mopLabelOrExpr = case mopExpr of diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 799dec3..5941a8c 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1882,7 +1882,10 @@ outOfLineFloatOp mop res args code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) return (code1 `appOL` code2) where - lbl = mkForeignLabel fn Nothing False IsFunction + -- 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 is because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31 + lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction fn = case mop of MO_F32_Sqrt -> fsLit "sqrtf" diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 49a0946..f230187 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -985,9 +985,10 @@ mkImport :: CCallConv -> P (HsDecl RdrName) mkImport cconv safety (L loc entity, v, ty) | cconv == PrimCallConv = do - let funcTarget = CFunction (StaticTarget entity) - importSpec = CImport PrimCallConv safety nilFS funcTarget - return (ForD (ForeignImport v ty importSpec)) + let funcTarget = CFunction (PackageTarget entity Nothing) + importSpec = CImport PrimCallConv safety nilFS funcTarget + return (ForD (ForeignImport v ty importSpec)) + | otherwise = do case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of Nothing -> parseError loc "Malformed entity string" @@ -1022,7 +1023,7 @@ parseCImport cconv safety nm str = id_char c = isAlphaNum c || c == '_' cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) - +++ ((CFunction . StaticTarget) <$> cid) + +++ ((\c -> CFunction (PackageTarget c Nothing)) <$> cid) where cid = return nm +++ (do c <- satisfy (\c -> isAlpha c || c == '_') diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index e2f5320..578ab3c 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -24,6 +24,7 @@ module ForeignCall ( import FastString import Binary import Outputable +import Module import Data.Char \end{code} @@ -101,9 +102,19 @@ data CCallSpec The call target: \begin{code} + +-- | How to call a particular function in C land. data CCallTarget - = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'. - | DynamicTarget -- First argument (an Addr#) is the function pointer + -- An "unboxed" ccall# to named function + = StaticTarget CLabelString + + -- The first argument of the import is the name of a function pointer (an Addr#). + -- Used when importing a label as "foreign import ccall "dynamic" ..." + | DynamicTarget + + -- An "unboxed" ccall# to a named function from a particular package. + | PackageTarget CLabelString (Maybe PackageId) + deriving( Eq ) {-! derive: Binary !-} @@ -186,8 +197,17 @@ instance Outputable CCallSpec where gc_suf | playSafe safety = text "_GC" | otherwise = empty - ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\"" - ppr_fun (StaticTarget fn) = text "__ccall" <> gc_suf <+> pprCLabelString fn + ppr_fun DynamicTarget + = text "__dyn_ccall" <> gc_suf <+> text "\"\"" + + ppr_fun (PackageTarget fn Nothing) + = text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn + + ppr_fun (PackageTarget fn (Just pkgId)) + = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn + + ppr_fun (StaticTarget fn) + = text "__ccall" <> gc_suf <+> pprCLabelString fn \end{code} @@ -242,12 +262,19 @@ instance Binary CCallTarget where put_ bh aa put_ bh DynamicTarget = do putByte bh 1 + put_ bh (PackageTarget aa ab) = do + putByte bh 2 + put_ bh aa + put_ bh ab get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (StaticTarget aa) - _ -> do return DynamicTarget + 1 -> do return DynamicTarget + _ -> do aa <- get bh + ab <- get bh + return (PackageTarget aa ab) instance Binary CCallConv where put_ bh CCallConv = do diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index 4ac1577..8c532ff 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -43,6 +43,7 @@ import Unique ( Unique, mkPrimOpIdUnique ) import Outputable import FastTypes import FastString +import Module ( PackageId ) \end{code} %************************************************************************ @@ -517,9 +518,10 @@ pprPrimOp other_op = pprOccName (primOpOcc other_op) %************************************************************************ \begin{code} -newtype PrimCall = PrimCall CLabelString +data PrimCall = PrimCall CLabelString PackageId instance Outputable PrimCall where - ppr (PrimCall lbl) = ppr lbl + ppr (PrimCall lbl pkgId) + = text "__primcall" <+> ppr pkgId <+> ppr lbl \end{code} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 9842d45..2911ce0 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -31,6 +31,8 @@ import HscTypes ( GenAvailInfo(..), availsToNameSet ) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad +import ForeignCall ( CCallTarget(..) ) +import Module import HscTypes ( Warnings(..), plusWarns ) import Class ( FunDep ) import Name ( Name, nameOccName ) @@ -41,10 +43,12 @@ import Bag import FastString import Util ( filterOut ) import SrcLoc -import DynFlags ( DynFlag(..) ) +import DynFlags ( DynFlag(..), DynFlags, thisPackage ) +import HscTypes ( HscEnv, hsc_dflags ) import BasicTypes ( Boxity(..) ) import ListSetOps ( findDupsEq ) + import Control.Monad import Data.Maybe \end{code} @@ -368,9 +372,15 @@ rnDefaultDecl (DefaultDecl tys) \begin{code} rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) rnHsForeignDecl (ForeignImport name ty spec) - = lookupLocatedTopBndrRn name `thenM` \ name' -> + = getTopEnv `thenM` \ (topEnv :: HscEnv) -> + lookupLocatedTopBndrRn name `thenM` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - return (ForeignImport name' ty' spec, fvs) + + -- Mark any PackageTarget style imports as coming from the current package + let packageId = thisPackage $ hsc_dflags topEnv + spec' = patchForeignImport packageId spec + + in return (ForeignImport name' ty' spec', fvs) rnHsForeignDecl (ForeignExport name ty spec) = lookupLocatedOccRn name `thenM` \ name' -> @@ -382,6 +392,32 @@ rnHsForeignDecl (ForeignExport name ty spec) fo_decl_msg :: Located RdrName -> SDoc fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name + + +-- | For Windows DLLs we need to know what packages imported symbols are from +-- to generate correct calls. Imported symbols are tagged with the current +-- package, so if they get inlined across a package boundry we'll still +-- know where they're from. +-- +patchForeignImport :: PackageId -> ForeignImport -> ForeignImport +patchForeignImport packageId (CImport cconv safety fs spec) + = CImport cconv safety fs (patchCImportSpec packageId spec) + +patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec +patchCImportSpec packageId spec + = case spec of + CFunction callTarget -> CFunction $ patchCCallTarget packageId callTarget + _ -> spec + +patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget +patchCCallTarget packageId callTarget + = case callTarget of + PackageTarget label Nothing + -> PackageTarget label (Just packageId) + + _ -> callTarget + + \end{code} diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index b5484a4..f49f092 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -528,15 +528,20 @@ coreToStgApp _ f args = do res_ty = exprType (mkApps (Var f) args) app = case idDetails f of DataConWorkId dc | saturated -> StgConApp dc args' + + -- Some primitive operator that might be implemented as a library call. PrimOpId op -> ASSERT( saturated ) StgOpApp (StgPrimOp op) args' res_ty - FCallId (CCall (CCallSpec (StaticTarget lbl) PrimCallConv _)) - -- prim calls are represented as FCalls in core, - -- but in stg we distinguish them - -> ASSERT( saturated ) - StgOpApp (StgPrimCallOp (PrimCall lbl)) args' res_ty + + -- A call to some primitive Cmm function. + FCallId (CCall (CCallSpec (PackageTarget lbl (Just pkgId)) PrimCallConv _)) + -> ASSERT( saturated ) + StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty + + -- A regular foreign call. FCallId call -> ASSERT( saturated ) StgOpApp (StgFCallOp call (idUnique f)) args' res_ty + TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') _other -> StgApp f args' diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 83f719b..1901357 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -158,14 +158,21 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar checkMissingAmpersand dflags arg_tys res_ty return idecl + -- This makes a convenient place to check -- that the C identifier is valid for C checkCTarget :: CCallTarget -> TcM () checkCTarget (StaticTarget str) = do checkCg checkCOrAsmOrDotNetOrInterp check (isCLabelString str) (badCName str) + +checkCTarget (PackageTarget str _) = do + checkCg checkCOrAsmOrDotNetOrInterp + check (isCLabelString str) (badCName str) + checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" + checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () checkMissingAmpersand dflags arg_tys res_ty | null arg_tys && isFunPtrTy res_ty &&