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
e239aa23
Commit
e239aa23
authored
Mar 23, 2009
by
dias@eecs.tufts.edu
Browse files
Small step toward call-conv improvement: separate out calls and returns
parent
f9d5c95f
Changes
9
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CmmCallConv.hs
View file @
e239aa23
...
...
@@ -56,19 +56,21 @@ 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
(
_
,
Native
)
->
getRegsWithoutNode
(
_
,
Native
Call
)
->
getRegsWithoutNode
(
_
,
GC
)
->
getRegsWithNode
(
_
,
PrimOp
)
->
allRegs
(
_
,
PrimOp
Call
)
->
allRegs
(
_
,
Slow
)
->
noRegs
(
_
,
_
)
->
getRegsWithoutNode
_
->
panic
"Unknown calling convention"
else
case
(
reps
,
conv
)
of
([
_
],
_
)
->
allRegs
(
_
,
Native
)
->
getRegsWithNode
(
_
,
NativeCall
)
->
getRegsWithNode
(
_
,
NativeReturn
)
->
getRegsWithNode
(
_
,
GC
)
->
getRegsWithNode
(
_
,
PrimOp
)
->
getRegsWithNode
(
_
,
PrimOpCall
)
->
getRegsWithNode
(
_
,
PrimOpReturn
)
->
getRegsWithNode
(
_
,
Slow
)
->
noRegs
(
_
,
_
)
->
getRegsWithNode
_
->
pprPanic
"Unknown calling convention"
(
ppr
conv
)
(
sizes
,
assignments
)
=
unzip
$
assignArguments'
reps
(
sum
sizes
)
regs
assignArguments'
[]
_
_
=
[]
assignArguments'
(
r
:
rs
)
offset
avails
=
...
...
compiler/cmm/CmmCvt.hs
View file @
e239aa23
...
...
@@ -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
Native
args
in
let
(
offset
,
entry
)
=
mkEntry
id
Native
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
get_conv
(
PrimTarget
_
)
=
Native
Call
get_conv
(
ForeignTarget
_
fc
)
=
Foreign
fc
cmm_target
::
MidCallTarget
->
CmmCallTarget
...
...
compiler/cmm/MkZipCfgCmm.hs
View file @
e239aa23
...
...
@@ -244,22 +244,22 @@ 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
Native
actuals
updfr_off
$
toCall
e
Nothing
updfr_off
0
lastWithArgs
Jump
old
Native
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
=
lastWithArgs
Jump
old
conv
actuals
updfr_off
$
toCall
e
Nothing
updfr_off
0
mkReturn
e
actuals
updfr_off
=
lastWithArgs
Ret
old
Native
actuals
updfr_off
$
toCall
e
Nothing
updfr_off
0
lastWithArgs
Ret
old
Native
Return
actuals
updfr_off
$
toCall
e
Nothing
updfr_off
0
-- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
mkReturnSimple
actuals
updfr_off
=
lastWithArgs
Ret
old
Native
actuals
updfr_off
$
toCall
e
Nothing
updfr_off
0
lastWithArgs
Ret
old
Native
Return
actuals
updfr_off
$
toCall
e
Nothing
updfr_off
0
where
e
=
CmmLoad
(
CmmStackSlot
(
CallArea
Old
)
updfr_off
)
gcWord
mkFinalCall
f
_
actuals
updfr_off
=
lastWithArgs
Call
old
Native
actuals
updfr_off
$
toCall
f
Nothing
updfr_off
0
lastWithArgs
Call
old
Native
Call
actuals
updfr_off
$
toCall
f
Nothing
updfr_off
0
mkCmmCall
f
results
actuals
=
mkCall
f
Native
results
actuals
mkCmmCall
f
results
actuals
=
mkCall
f
Native
Call
results
actuals
-- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
mkCall
f
conv
results
actuals
updfr_off
=
...
...
compiler/cmm/ZipCfgCmmRep.hs
View file @
e239aa23
...
...
@@ -110,13 +110,17 @@ data MidCallTarget -- The target of a MidUnsafeCall
deriving
Eq
data
Convention
=
Native
-- Native C-- call/return
=
NativeCall
-- Native C-- call
|
NativeReturn
-- Native C-- return
|
Slow
-- Slow entry points: all args pushed on the stack
|
GC
-- Entry to the garbage collector: uses the node reg!
|
PrimOp
-- Calling prim ops
|
PrimOpCall
-- Calling prim ops
|
PrimOpReturn
-- Returning from prim ops
|
Foreign
-- Foreign call/return
ForeignConvention
...
...
@@ -516,12 +520,14 @@ genFullCondBranch expr t f =
]
pprConvention
::
Convention
->
SDoc
pprConvention
(
Native
{})
=
text
"<native-convention>"
pprConvention
Slow
=
text
"<slow-convention>"
pprConvention
GC
=
text
"<gc-convention>"
pprConvention
PrimOp
=
text
"<primop-convention>"
pprConvention
(
Foreign
c
)
=
ppr
c
pprConvention
(
Private
{})
=
text
"<private-convention>"
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>"
pprForeignConvention
::
ForeignConvention
->
SDoc
pprForeignConvention
(
ForeignConvention
c
as
rs
)
=
ppr
c
<>
ppr
as
<>
ppr
rs
...
...
compiler/codeGen/StgCmmExpr.hs
View file @
e239aa23
...
...
@@ -465,7 +465,7 @@ cgTailCall fun_id fun_info args = do
;
[
ret
,
call
]
<-
forkAlts
[
getCode
$
emitReturn
[
fun
],
-- Is tagged; no need to untag
getCode
$
do
emit
(
mkAssign
nodeReg
fun
)
emitCall
Native
(
entryCode
fun'
)
[]
]
-- Not tagged
emitCall
Native
Call
(
entryCode
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 @
e239aa23
...
...
@@ -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
Native
target
args
=
emitCall
Native
Call
target
args
|
otherwise
-- Over-saturated call
=
ASSERT
(
arity
==
length
initial_reps
)
do
{
pap_id
<-
newTemp
gcWord
;
withSequel
(
AssignTo
[
pap_id
]
True
)
(
emitCall
Native
target
fast_args
)
(
emitCall
Native
Call
target
fast_args
)
;
slow_call
(
CmmReg
(
CmmLocal
pap_id
))
rest_args
rest_reps
}
where
...
...
compiler/codeGen/StgCmmMonad.hs
View file @
e239aa23
...
...
@@ -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
Native
emitProc
=
emitProcWithConvention
Native
Call
emitSimpleProc
::
CLabel
->
CmmAGraph
->
FCode
()
emitSimpleProc
lbl
code
=
...
...
compiler/codeGen/StgCmmPrim.hs
View file @
e239aa23
...
...
@@ -82,7 +82,7 @@ cgOpApp (StgPrimOp primop) args res_ty
|
primOpOutOfLine
primop
=
do
{
cmm_args
<-
getNonVoidArgAmodes
args
;
let
fun
=
CmmLit
(
CmmLabel
(
mkRtsPrimOpLabel
primop
))
;
emitCall
PrimOp
fun
cmm_args
}
;
emitCall
PrimOp
Call
fun
cmm_args
}
|
ReturnsPrim
VoidRep
<-
result_info
=
do
cgPrimOp
[]
primop
args
...
...
compiler/codeGen/StgCmmUtils.hs
View file @
e239aa23
...
...
@@ -314,7 +314,7 @@ emitRtsCall' res fun args _vols safe
where
call
updfr_off
=
if
safe
then
mkCall
fun_expr
Native
res'
args'
updfr_off
mkCall
fun_expr
Native
Call
res'
args'
updfr_off
else
mkUnsafeCall
(
ForeignTarget
fun_expr
(
ForeignConvention
CCallConv
arg_hints
res_hints
))
res'
args'
...
...
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