Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
4,323
Issues
4,323
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
377
Merge Requests
377
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
7854ec4b
Commit
7854ec4b
authored
Jan 02, 2010
by
Ben.Lippmeier@anu.edu.au
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Tag ForeignCalls with the package they correspond to
parent
e5fba2f5
Changes
21
Hide whitespace changes
Inline
Side-by-side
Showing
21 changed files
with
305 additions
and
83 deletions
+305
-83
compiler/cmm/CLabel.hs
compiler/cmm/CLabel.hs
+117
-27
compiler/cmm/CmmParse.y
compiler/cmm/CmmParse.y
+12
-5
compiler/cmm/PprCmm.hs
compiler/cmm/PprCmm.hs
+6
-1
compiler/cmm/ZipCfgCmmRep.hs
compiler/cmm/ZipCfgCmmRep.hs
+6
-2
compiler/codeGen/CgExtCode.hs
compiler/codeGen/CgExtCode.hs
+8
-10
compiler/codeGen/CgForeignCall.hs
compiler/codeGen/CgForeignCall.hs
+21
-2
compiler/codeGen/CgHpc.hs
compiler/codeGen/CgHpc.hs
+1
-1
compiler/codeGen/CgUtils.hs
compiler/codeGen/CgUtils.hs
+5
-3
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmForeign.hs
+1
-1
compiler/codeGen/StgCmmHpc.hs
compiler/codeGen/StgCmmHpc.hs
+1
-1
compiler/codeGen/StgCmmUtils.hs
compiler/codeGen/StgCmmUtils.hs
+5
-3
compiler/main/StaticFlags.hs
compiler/main/StaticFlags.hs
+8
-1
compiler/nativeGen/PIC.hs
compiler/nativeGen/PIC.hs
+12
-5
compiler/nativeGen/SPARC/CodeGen/CCall.hs
compiler/nativeGen/SPARC/CodeGen/CCall.hs
+1
-1
compiler/nativeGen/X86/CodeGen.hs
compiler/nativeGen/X86/CodeGen.hs
+4
-1
compiler/parser/RdrHsSyn.lhs
compiler/parser/RdrHsSyn.lhs
+5
-4
compiler/prelude/ForeignCall.lhs
compiler/prelude/ForeignCall.lhs
+32
-5
compiler/prelude/PrimOp.lhs
compiler/prelude/PrimOp.lhs
+4
-2
compiler/rename/RnSource.lhs
compiler/rename/RnSource.lhs
+39
-3
compiler/stgSyn/CoreToStg.lhs
compiler/stgSyn/CoreToStg.lhs
+10
-5
compiler/typecheck/TcForeign.lhs
compiler/typecheck/TcForeign.lhs
+7
-0
No files found.
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
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
...
...
compiler/prelude/PrimOp.lhs
View file @
7854ec4b
...
...
@@ -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