Tag ForeignCalls with the package they correspond to

parent e5fba2f5
......@@ -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.
......
......@@ -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] }
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 []"
......
......@@ -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
......
......@@ -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
......
......@@ -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 []"
......
......@@ -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)
......
......@@ -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
......
......@@ -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"
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -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 == '_')
......
......@@ -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
......
......@@ -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}
......@@ -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}
......
......@@ -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'