Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
7854ec4b
Commit
7854ec4b
authored
Jan 02, 2010
by
Ben.Lippmeier@anu.edu.au
Browse files
Tag ForeignCalls with the package they correspond to
parent
e5fba2f5
Changes
21
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CLabel.hs
View file @
7854ec4b
...
...
@@ -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_dynami
c
fod
addLabelSize
(
ForeignLabel
str
_
src
fod
)
sz
=
ForeignLabel
str
(
Just
sz
)
sr
c
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
_
_
_
)
=
Fals
e
needsCDecl
l
@
(
ForeignLabel
_
_
_
_
)
=
not
(
isMathFun
l
)
needsCDecl
(
CmmLabel
_
_
_
)
=
Tru
e
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.
...
...
compiler/cmm/CmmParse.y
View file @
7854ec4b
...
...
@@ -214,7 +214,7 @@ static :: { ExtFCode [CmmStatic] }
| 'CLOSURE' '(' NAME lits ')'
{ do lits <- sequence $4;
return $ map CmmStaticLit $
mkStaticClosure (mkForeignLabel $3 Nothing
Tru
e IsData)
mkStaticClosure (mkForeignLabel $3 Nothing
ForeignLabelInExternalPackag
e 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] }
...
...
compiler/cmm/PprCmm.hs
View file @
7854ec4b
...
...
@@ -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
...
...
compiler/cmm/ZipCfgCmmRep.hs
View file @
7854ec4b
...
...
@@ -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
...
...
compiler/codeGen/CgExtCode.hs
View file @
7854ec4b
...
...
@@ -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
...
...
compiler/codeGen/CgForeignCall.hs
View file @
7854ec4b
...
...
@@ -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 []"
...
...
compiler/codeGen/CgHpc.hs
View file @
7854ec4b
...
...
@@ -67,7 +67,7 @@ initHpc this_mod (HpcInfo tickCount hashNo)
PlayRisky
[
CmmHinted
id
NoHint
]
(
CmmCallee
(
CmmLit
$
CmmLabel
$
mkForeignLabel
mod_alloc
Nothing
F
als
e
IsFunction
)
(
CmmLit
$
CmmLabel
$
mkForeignLabel
mod_alloc
Nothing
F
oreignLabelInThisPackag
e
IsFunction
)
CCallConv
)
[
CmmHinted
(
mkLblExpr
mkHpcModuleNameLabel
)
AddrHint
...
...
compiler/codeGen/CgUtils.hs
View file @
7854ec4b
...
...
@@ -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
...
...
compiler/codeGen/StgCmmForeign.hs
View file @
7854ec4b
...
...
@@ -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
)
F
als
e
IsFunction
)))
F
oreignLabelInThisPackag
e
IsFunction
)))
DynamicTarget
->
case
cmm_args
of
(
fn
,
_
)
:
rest
->
(
unzip
rest
,
fn
)
[]
->
panic
"cgForeignCall []"
...
...
compiler/codeGen/StgCmmHpc.hs
View file @
7854ec4b
...
...
@@ -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
F
als
e
IsFunction
)
(
CmmLit
$
CmmLabel
$
mkForeignLabel
mod_alloc
Nothing
F
oreignLabelInThisPackag
e
IsFunction
)
[
(
mkLblExpr
mkHpcModuleNameLabel
,
AddrHint
)
,
(
CmmLit
$
mkIntCLit
tickCount
,
NoHint
)
,
(
CmmLit
$
mkIntCLit
hashNo
,
NoHint
)
...
...
compiler/codeGen/StgCmmUtils.hs
View file @
7854ec4b
...
...
@@ -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
...
...
compiler/main/StaticFlags.hs
View file @
7854ec4b
...
...
@@ -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"
...
...
compiler/nativeGen/PIC.hs
View file @
7854ec4b
...
...
@@ -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
...
...
compiler/nativeGen/SPARC/CodeGen/CCall.hs
View file @
7854ec4b
...
...
@@ -263,7 +263,7 @@ outOfLineFloatOp mop
dflags
<-
getDynFlagsNat
mopExpr
<-
cmmMakeDynamicReference
dflags
addImportNat
CallReference
$
mkForeignLabel
functionName
Nothing
Tru
e
IsFunction
$
mkForeignLabel
functionName
Nothing
ForeignLabelInExternalPackag
e
IsFunction
let
mopLabelOrExpr
=
case
mopExpr
of
...
...
compiler/nativeGen/X86/CodeGen.hs
View file @
7854ec4b
...
...
@@ -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"
...
...
compiler/parser/RdrHsSyn.lhs
View file @
7854ec4b
...
...
@@ -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 == '_')
...
...
compiler/prelude/ForeignCall.lhs
View file @
7854ec4b
...
...
@@ -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