Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
jberryman
GHC
Commits
617eb195
Commit
617eb195
authored
Mar 23, 2009
by
dias@eecs.tufts.edu
Browse files
Calls with and without passing node arguments more clearly separated
parent
5d1c70a5
Changes
7
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CmmCallConv.hs
View file @
617eb195
...
...
@@ -56,7 +56,8 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
where
-- The calling conventions (CgCallConv.hs) are complicated, to say the least
regs
=
if
isCall
then
case
(
reps
,
conv
)
of
(
_
,
NativeCall
)
->
getRegsWithoutNode
(
_
,
NativeNodeCall
)
->
getRegsWithNode
(
_
,
NativeDirectCall
)
->
getRegsWithoutNode
(
_
,
GC
)
->
getRegsWithNode
(
_
,
PrimOpCall
)
->
allRegs
(
_
,
Slow
)
->
noRegs
...
...
@@ -64,12 +65,22 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
else
case
(
reps
,
conv
)
of
([
_
],
_
)
->
allRegs
(
_
,
NativeCall
)
->
getRegsWithNode
(
_
,
NativeNodeCall
)
->
getRegsWithNode
(
_
,
NativeDirectCall
)
->
getRegsWithoutNode
(
_
,
NativeReturn
)
->
getRegsWithNode
(
_
,
GC
)
->
getRegsWithNode
(
_
,
PrimOpReturn
)
->
getRegsWithNode
(
_
,
Slow
)
->
noRegs
_
->
pprPanic
"Unknown calling convention"
(
ppr
conv
)
-- (_, NativeCall) -> getRegsWithoutNode
-- (_, GC ) -> getRegsWithNode
-- (_, PrimOpCall) -> allRegs
-- (_, Slow ) -> noRegs
-- _ -> panic "Unknown calling convention"
-- else
-- case (reps, conv) of
-- ([_], _) -> allRegs
-- (_, NativeCall) -> getRegsWithNode
(
sizes
,
assignments
)
=
unzip
$
assignArguments'
reps
(
sum
sizes
)
regs
assignArguments'
[]
_
_
=
[]
assignArguments'
(
r
:
rs
)
offset
avails
=
...
...
compiler/cmm/CmmCvt.hs
View file @
617eb195
...
...
@@ -36,7 +36,7 @@ toZgraph _ _ (ListGraph []) =
do
g
<-
lgraphOfAGraph
emptyAGraph
return
((
0
,
Nothing
),
g
)
toZgraph
fun_name
args
g
@
(
ListGraph
(
BasicBlock
id
ss
:
other_blocks
))
=
let
(
offset
,
entry
)
=
mkEntry
id
NativeCall
args
in
let
(
offset
,
entry
)
=
mkEntry
id
Native
Node
Call
args
in
do
g
<-
labelAGraph
id
$
entry
<*>
mkStmts
ss
<*>
foldr
addBlock
emptyAGraph
other_blocks
return
((
offset
,
Nothing
),
g
)
...
...
@@ -94,7 +94,7 @@ get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints
get_hints
_other_conv
_vd
=
repeat
NoHint
get_conv
::
MidCallTarget
->
Convention
get_conv
(
PrimTarget
_
)
=
Native
Call
get_conv
(
PrimTarget
_
)
=
Native
NodeCall
-- JD: SUSPICIOUS
get_conv
(
ForeignTarget
_
fc
)
=
Foreign
fc
cmm_target
::
MidCallTarget
->
CmmCallTarget
...
...
compiler/cmm/MkZipCfgCmm.hs
View file @
617eb195
...
...
@@ -244,7 +244,7 @@ toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> La
toCall
e
cont
updfr_off
res_space
arg_space
=
LastCall
e
cont
arg_space
res_space
(
Just
updfr_off
)
mkJump
e
actuals
updfr_off
=
lastWithArgs
Jump
old
NativeCall
actuals
updfr_off
$
toCall
e
Nothing
updfr_off
0
lastWithArgs
Jump
old
Native
Node
Call
actuals
updfr_off
$
toCall
e
Nothing
updfr_off
0
mkJumpGC
e
actuals
updfr_off
=
lastWithArgs
Jump
old
GC
actuals
updfr_off
$
toCall
e
Nothing
updfr_off
0
mkForeignJump
conv
e
actuals
updfr_off
=
...
...
@@ -257,9 +257,9 @@ mkReturnSimple actuals updfr_off =
where
e
=
CmmLoad
(
CmmStackSlot
(
CallArea
Old
)
updfr_off
)
gcWord
mkFinalCall
f
_
actuals
updfr_off
=
lastWithArgs
Call
old
NativeCall
actuals
updfr_off
$
toCall
f
Nothing
updfr_off
0
lastWithArgs
Call
old
Native
Direct
Call
actuals
updfr_off
$
toCall
f
Nothing
updfr_off
0
mkCmmCall
f
results
actuals
=
mkCall
f
(
NativeCall
,
NativeReturn
)
results
actuals
mkCmmCall
f
results
actuals
=
mkCall
f
(
Native
Direct
Call
,
NativeReturn
)
results
actuals
-- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
mkCall
f
(
callConv
,
retConv
)
results
actuals
updfr_off
=
...
...
compiler/cmm/ZipCfgCmmRep.hs
View file @
617eb195
...
...
@@ -110,7 +110,9 @@ data MidCallTarget -- The target of a MidUnsafeCall
deriving
Eq
data
Convention
=
NativeCall
-- Native C-- call
=
NativeDirectCall
-- Native C-- call skipping the node (closure) argument
|
NativeNodeCall
-- Native C-- call including the node argument
|
NativeReturn
-- Native C-- return
...
...
@@ -520,14 +522,15 @@ genFullCondBranch expr t f =
]
pprConvention
::
Convention
->
SDoc
pprConvention
(
NativeCall
{})
=
text
"<native-call-convention>"
pprConvention
(
NativeReturn
{})
=
text
"<native-ret-convention>"
pprConvention
Slow
=
text
"<slow-convention>"
pprConvention
GC
=
text
"<gc-convention>"
pprConvention
PrimOpCall
=
text
"<primop-call-convention>"
pprConvention
PrimOpReturn
=
text
"<primop-ret-convention>"
pprConvention
(
Foreign
c
)
=
ppr
c
pprConvention
(
Private
{})
=
text
"<private-convention>"
pprConvention
(
NativeNodeCall
{})
=
text
"<native-node-call-convention>"
pprConvention
(
NativeDirectCall
{})
=
text
"<native-direct-call-convention>"
pprConvention
(
NativeReturn
{})
=
text
"<native-ret-convention>"
pprConvention
Slow
=
text
"<slow-convention>"
pprConvention
GC
=
text
"<gc-convention>"
pprConvention
PrimOpCall
=
text
"<primop-call-convention>"
pprConvention
PrimOpReturn
=
text
"<primop-ret-convention>"
pprConvention
(
Foreign
c
)
=
ppr
c
pprConvention
(
Private
{})
=
text
"<private-convention>"
pprForeignConvention
::
ForeignConvention
->
SDoc
pprForeignConvention
(
ForeignConvention
c
as
rs
)
=
ppr
c
<>
ppr
as
<>
ppr
rs
...
...
compiler/codeGen/StgCmmExpr.hs
View file @
617eb195
...
...
@@ -464,9 +464,9 @@ cgTailCall fun_id fun_info args = do
do
{
let
fun'
=
CmmLoad
fun
(
cmmExprType
fun
)
;
[
ret
,
call
]
<-
forkAlts
[
getCode
$
emitReturn
[
fun
],
-- Is tagged; no need to untag
getCode
$
do
emit
(
mkAssign
nodeReg
fun
)
emitCall
(
NativeCall
,
NativeReturn
)
(
entryCode
fun'
)
[]
]
-- Not tagged
getCode
$
do
--
emit (mkAssign nodeReg fun)
emitCall
(
Native
Node
Call
,
NativeReturn
)
(
entryCode
fun'
)
[
fun
]]
-- Not tagged
;
emit
(
mkCmmIfThenElse
(
cmmIsTagged
fun
)
ret
call
)
}
SlowCall
->
do
-- A slow function call via the RTS apply routines
...
...
compiler/codeGen/StgCmmLayout.hs
View file @
617eb195
...
...
@@ -161,13 +161,13 @@ direct_call caller lbl arity args reps
<+>
ppr
args
<+>
ppr
reps
)
|
null
rest_reps
-- Precisely the right number of arguments
=
emitCall
(
NativeCall
,
NativeReturn
)
target
args
=
emitCall
(
Native
Direct
Call
,
NativeReturn
)
target
args
|
otherwise
-- Over-saturated call
=
ASSERT
(
arity
==
length
initial_reps
)
do
{
pap_id
<-
newTemp
gcWord
;
withSequel
(
AssignTo
[
pap_id
]
True
)
(
emitCall
(
NativeCall
,
NativeReturn
)
target
fast_args
)
(
emitCall
(
Native
Direct
Call
,
NativeReturn
)
target
fast_args
)
;
slow_call
(
CmmReg
(
CmmLocal
pap_id
))
rest_args
rest_reps
}
where
...
...
compiler/codeGen/StgCmmMonad.hs
View file @
617eb195
...
...
@@ -607,7 +607,7 @@ emitProcWithConvention conv info lbl args blocks
;
setState
$
state
{
cgs_tops
=
cgs_tops
state
`
snocOL
`
proc_block
}
}
emitProc
::
CmmInfo
->
CLabel
->
CmmFormals
->
CmmAGraph
->
FCode
()
emitProc
=
emitProcWithConvention
NativeCall
emitProc
=
emitProcWithConvention
Native
Node
Call
emitSimpleProc
::
CLabel
->
CmmAGraph
->
FCode
()
emitSimpleProc
lbl
code
=
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment