module CLabel (
CLabel, -- abstract type
+ ForeignLabelSource(..),
+ pprDebugCLabel,
mkClosureLabel,
mkSRTLabel,
| 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.
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
| 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
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
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
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 [
]
-- -----------------------------------------------------------------------------
--- 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
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
labelType (ModuleInitTableLabel _) = DataLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
-labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
+labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
labelType (IdLabel _ _ info) = idInfoLabelType info
labelType _ = DataLabel
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)
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")
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.
| '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) [] [] [] }
-- 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] }
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
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
newLabel,
newFunctionName,
newImport,
-
lookupLabel,
lookupName,
import CLabel
import Cmm
-import BasicTypes
+-- import BasicTypes
import BlockId
import FastString
import Module
-- | 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
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 []"
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
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
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 []"
; 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)
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
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"
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 )
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
-> 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
-- 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
dflags <- getDynFlagsNat
mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference
- $ mkForeignLabel functionName Nothing True IsFunction
+ $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction
let mopLabelOrExpr
= case mopExpr of
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"
-> 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"
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 == '_')
import FastString
import Binary
import Outputable
+import Module
import Data.Char
\end{code}
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 !-}
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}
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
import Outputable
import FastTypes
import FastString
+import Module ( PackageId )
\end{code}
%************************************************************************
%************************************************************************
\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}
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
+import ForeignCall ( CCallTarget(..) )
+import Module
import HscTypes ( Warnings(..), plusWarns )
import Class ( FunDep )
import Name ( Name, nameOccName )
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}
\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' ->
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}
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'
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 &&
projects / ghc-hetmet.git / commitdiff