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
5d1c70a5
Commit
5d1c70a5
authored
Mar 23, 2009
by
dias@eecs.tufts.edu
Browse files
Another small step: call and return conventions specified separately when making calls
parent
e239aa23
Changes
9
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CmmCallConv.hs
View file @
5d1c70a5
...
...
@@ -60,14 +60,13 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
(
_
,
GC
)
->
getRegsWithNode
(
_
,
PrimOpCall
)
->
allRegs
(
_
,
Slow
)
->
noRegs
_
->
panic
"Unknown calling convention"
_
->
p
prP
anic
"Unknown calling convention"
(
ppr
conv
)
else
case
(
reps
,
conv
)
of
([
_
],
_
)
->
allRegs
(
_
,
NativeCall
)
->
getRegsWithNode
(
_
,
NativeReturn
)
->
getRegsWithNode
(
_
,
GC
)
->
getRegsWithNode
(
_
,
PrimOpCall
)
->
getRegsWithNode
(
_
,
PrimOpReturn
)
->
getRegsWithNode
(
_
,
Slow
)
->
noRegs
_
->
pprPanic
"Unknown calling convention"
(
ppr
conv
)
...
...
compiler/cmm/CmmCvt.hs
View file @
5d1c70a5
...
...
@@ -48,7 +48,7 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
mkStmts
(
CmmAssign
l
r
:
ss
)
=
mkAssign
l
r
<*>
mkStmts
ss
mkStmts
(
CmmStore
l
r
:
ss
)
=
mkStore
l
r
<*>
mkStmts
ss
mkStmts
(
CmmCall
(
CmmCallee
f
conv
)
res
args
(
CmmSafe
_
)
CmmMayReturn
:
ss
)
=
mkCall
f
conv'
(
map
hintlessCmm
res
)
(
map
hintlessCmm
args
)
updfr_sz
mkCall
f
(
conv'
,
conv'
)
(
map
hintlessCmm
res
)
(
map
hintlessCmm
args
)
updfr_sz
<*>
mkStmts
ss
where
conv'
=
Foreign
(
ForeignConvention
conv
[]
[]
)
-- JD: DUBIOUS
mkStmts
(
CmmCall
(
CmmPrim
{})
_
_
(
CmmSafe
_
)
_
:
_
)
=
...
...
compiler/cmm/MkZipCfgCmm.hs
View file @
5d1c70a5
...
...
@@ -60,7 +60,7 @@ mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
mkStore
::
CmmExpr
->
CmmExpr
->
CmmAGraph
---------- Calls
mkCall
::
CmmExpr
->
Convention
->
CmmFormals
->
CmmActuals
->
mkCall
::
CmmExpr
->
(
Convention
,
Convention
)
->
CmmFormals
->
CmmActuals
->
UpdFrameOffset
->
CmmAGraph
mkCmmCall
::
CmmExpr
->
CmmFormals
->
CmmActuals
->
UpdFrameOffset
->
CmmAGraph
...
...
@@ -259,14 +259,15 @@ mkReturnSimple actuals updfr_off =
mkFinalCall
f
_
actuals
updfr_off
=
lastWithArgs
Call
old
NativeCall
actuals
updfr_off
$
toCall
f
Nothing
updfr_off
0
mkCmmCall
f
results
actuals
=
mkCall
f
NativeCall
results
actuals
mkCmmCall
f
results
actuals
=
mkCall
f
(
NativeCall
,
NativeReturn
)
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
=
pprTrace
"mkCall"
(
ppr
f
<+>
ppr
actuals
<+>
ppr
results
<+>
ppr
conv
)
$
mkCall
f
(
callConv
,
retConv
)
results
actuals
updfr_off
=
pprTrace
"mkCall"
(
ppr
f
<+>
ppr
actuals
<+>
ppr
results
<+>
ppr
callConv
<+>
ppr
retConv
)
$
withFreshLabel
"call successor"
$
\
k
->
let
area
=
CallArea
$
Young
k
(
off
,
copyin
)
=
copyInOflow
c
onv
False
area
results
copyout
=
lastWithArgs
Call
area
conv
actuals
updfr_off
(
off
,
copyin
)
=
copyInOflow
retC
onv
False
area
results
copyout
=
lastWithArgs
Call
area
c
allC
onv
actuals
updfr_off
(
toCall
f
(
Just
k
)
updfr_off
off
)
in
(
copyout
<*>
mkLabel
k
<*>
copyin
)
compiler/cmm/ZipCfgCmmRep.hs
View file @
5d1c70a5
...
...
@@ -114,16 +114,16 @@ data Convention
|
NativeReturn
-- Native C-- return
|
Slow
-- Slow entry points: all args pushed on the stack
|
Slow
-- Slow entry points: all args pushed on the stack
|
GC
-- Entry to the garbage collector: uses the node reg!
|
GC
-- Entry to the garbage collector: uses the node reg!
|
PrimOpCall
-- Calling prim ops
|
PrimOpReturn
-- Returning from prim ops
|
Foreign
-- Foreign call/return
ForeignConvention
|
Foreign
-- Foreign call/return
ForeignConvention
|
Private
-- Used for control transfers within a (pre-CPS) procedure All
...
...
compiler/codeGen/StgCmmExpr.hs
View file @
5d1c70a5
...
...
@@ -465,7 +465,8 @@ 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
NativeCall
(
entryCode
fun'
)
[]
]
-- Not tagged
emitCall
(
NativeCall
,
NativeReturn
)
(
entryCode
fun'
)
[]
]
-- Not tagged
;
emit
(
mkCmmIfThenElse
(
cmmIsTagged
fun
)
ret
call
)
}
SlowCall
->
do
-- A slow function call via the RTS apply routines
...
...
compiler/codeGen/StgCmmHeap.hs
View file @
5d1c70a5
...
...
@@ -352,7 +352,7 @@ entryHeapCheck fun arity args code
|
otherwise
=
case
gc_lbl
(
fun
:
args
)
of
Just
lbl
->
mkJumpGC
(
CmmLit
(
CmmLabel
(
mkRtsCodeLabel
lbl
)))
args'
updfr_sz
Nothing
->
mkCall
generic_gc
GC
[]
[]
updfr_sz
Nothing
->
mkCall
generic_gc
(
GC
,
GC
)
[]
[]
updfr_sz
gc_lbl
::
[
LocalReg
]
->
Maybe
LitString
{-
...
...
@@ -386,13 +386,13 @@ altHeapCheck regs code
heapCheck
False
(
gc_call
updfr_sz
)
code
where
gc_call
updfr_sz
|
null
regs
=
mkCall
generic_gc
GC
[]
[]
updfr_sz
|
null
regs
=
mkCall
generic_gc
(
GC
,
GC
)
[]
[]
updfr_sz
|
Just
gc_lbl
<-
rts_label
regs
-- Canned call
=
mkCall
(
CmmLit
(
CmmLabel
(
mkRtsCodeLabel
gc_lbl
)))
GC
=
mkCall
(
CmmLit
(
CmmLabel
(
mkRtsCodeLabel
gc_lbl
)))
(
GC
,
GC
)
regs
(
map
(
CmmReg
.
CmmLocal
)
regs
)
updfr_sz
|
otherwise
-- No canned call, and non-empty live vars
=
mkCall
generic_gc
GC
[]
[]
updfr_sz
=
mkCall
generic_gc
(
GC
,
GC
)
[]
[]
updfr_sz
{-
rts_label [reg]
...
...
compiler/codeGen/StgCmmLayout.hs
View file @
5d1c70a5
...
...
@@ -90,17 +90,17 @@ emitReturn results
;
emit
(
mkMultiAssign
regs
results
)
}
}
emitCall
::
Convention
->
CmmExpr
->
[
CmmExpr
]
->
FCode
()
emitCall
::
(
Convention
,
Convention
)
->
CmmExpr
->
[
CmmExpr
]
->
FCode
()
-- (cgCall fun args) makes a call to the entry-code of 'fun',
-- passing 'args', and returning the results to the current sequel
emitCall
conv
fun
args
emitCall
conv
s
@
(
callConv
,
_
)
fun
args
=
do
{
adjustHpBackwards
;
sequel
<-
getSequel
;
updfr_off
<-
getUpdFrameOff
;
emit
$
mkComment
$
mkFastString
(
"emitCall: "
++
show
sequel
)
;
case
sequel
of
Return
_
->
emit
(
mkForeignJump
conv
fun
args
updfr_off
)
AssignTo
res_regs
_
->
emit
(
mkCall
fun
conv
res_regs
args
updfr_off
)
Return
_
->
emit
(
mkForeignJump
c
allC
onv
fun
args
updfr_off
)
AssignTo
res_regs
_
->
emit
(
mkCall
fun
conv
s
res_regs
args
updfr_off
)
}
adjustHpBackwards
::
FCode
()
...
...
@@ -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
target
args
=
emitCall
(
NativeCall
,
NativeReturn
)
target
args
|
otherwise
-- Over-saturated call
=
ASSERT
(
arity
==
length
initial_reps
)
do
{
pap_id
<-
newTemp
gcWord
;
withSequel
(
AssignTo
[
pap_id
]
True
)
(
emitCall
NativeCall
target
fast_args
)
(
emitCall
(
NativeCall
,
NativeReturn
)
target
fast_args
)
;
slow_call
(
CmmReg
(
CmmLocal
pap_id
))
rest_args
rest_reps
}
where
...
...
compiler/codeGen/StgCmmPrim.hs
View file @
5d1c70a5
...
...
@@ -82,7 +82,7 @@ cgOpApp (StgPrimOp primop) args res_ty
|
primOpOutOfLine
primop
=
do
{
cmm_args
<-
getNonVoidArgAmodes
args
;
let
fun
=
CmmLit
(
CmmLabel
(
mkRtsPrimOpLabel
primop
))
;
emitCall
PrimOpCall
fun
cmm_args
}
;
emitCall
(
PrimOpCall
,
PrimOpReturn
)
fun
cmm_args
}
|
ReturnsPrim
VoidRep
<-
result_info
=
do
cgPrimOp
[]
primop
args
...
...
compiler/codeGen/StgCmmUtils.hs
View file @
5d1c70a5
...
...
@@ -314,7 +314,7 @@ emitRtsCall' res fun args _vols safe
where
call
updfr_off
=
if
safe
then
mkCall
fun_expr
NativeCall
res'
args'
updfr_off
mkC
mmC
all
fun_expr
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