Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Jon Boone
cmucl
Commits
6bc8fe20
Commit
6bc8fe20
authored
Jun 24, 2012
by
Raymond Toy
Browse files
Merge branch 'tcall-convention' of
https://github.com/ellerh/cmucl
into tcall-convention
parents
8a35f225
eac8d34c
Changes
17
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
6bc8fe20
...
...
@@ -350,14 +350,18 @@ cross-build:
bin/create-target.sh xtarget
cp
src/tools/cross-scripts/cross-x86-x86.lisp xtarget/cross.lisp
ifeq
($(XBOOTFILE),)
bin/cross-build-world.sh
-cr
l
\
bin/cross-build-world.sh
-cr
\
xtarget xcross xtarget/cross.lisp
$(BOOTCMUCL)
else
bin/cross-build-world.sh
-cr
l
\
bin/cross-build-world.sh
-cr
\
-B
$(XBOOTFILE)
xtarget xcross xtarget/cross.lisp
$(BOOTCMUCL)
endif
bin/rebuild-lisp.sh xtarget
bin/load-world.sh
-p
xtarget
"newlisp"
bin/create-target.sh xstage2
bin/build-world.sh xstage2 xtarget/lisp/lisp
bin/rebuild-lisp.sh xstage2
bin/load-world.sh xstage2
"newlisp2"
sanity
:
@
if
[
`
echo
$(TOPDIR)
| egrep
-c
'^/'
`
-ne
1
]
;
then
\
...
...
src/bootfiles/20c/tccxboot.lisp
View file @
6bc8fe20
...
...
@@ -3,7 +3,7 @@
(
c::define-info-type
function
c::calling-convention
symbol
nil
)
(
c::define-info-type
function
lisp::linkage
lisp::linkage
nil
)
(
delete-file
(
compile-file
"target:compiler/knownfun"
))
(
delete-file
(
compile-file
"target:code/load"
))
(
delete-file
(
compile-file
"target:compiler/knownfun"
:load
t
))
(
delete-file
(
compile-file
"target:code/load"
:load
t
))
src/code/exports.lisp
View file @
6bc8fe20
...
...
@@ -1760,8 +1760,7 @@
"TN-REF-NEXT"
"TN-REF-NEXT-REF"
"TN-REF-P"
"TN-REF-TARGET"
"TN-REF-TN"
"TN-REF-VOP"
"TN-REF-WRITE-P"
"TN-SC"
"TN-VALUE"
"TRACE-TABLE-ENTRY"
"TYPE-CHECK-ERROR"
"TYPED-CALL-LOCAL"
"TYPED-CALL-NAMED"
"TYPED-ENTRY-POINT-ALLOCATE-FRAME"
"TYPED-CALL-NAMED"
"TYPED-ENTRY-POINT-ALLOCATE-FRAME"
"UNBIND"
"UNBIND-TO-HERE"
"UNSAFE"
"UNWIND"
"UWP-ENTRY"
"VALUE-CELL-REF"
"VALUE-CELL-SET"
"VALUES-LIST"
...
...
src/code/fdefinition.lisp
View file @
6bc8fe20
...
...
@@ -288,11 +288,16 @@
(
equal
(
cadr
fname
)
name
))
(
return
ep
)))))
(
defun
find-typed-entry-point-for-function
(
xep
name
)
(
declare
(
type
function
xep
))
(
when
(
=
(
kernel:get-type
xep
)
vm:function-header-type
)
(
let
((
code
(
function-code-header
xep
)))
(
find-typed-entry-point-in-code
code
name
))))
(
defun
find-typed-entry-point-for-fdefn
(
fdefn
)
(
let
((
xep
(
fdefn-function
fdefn
)))
(
when
xep
(
let
((
code
(
function-code-header
xep
)))
(
find-typed-entry-point-in-code
code
(
fdefn-name
fdefn
))))))
(
when
(
functionp
xep
)
(
find-typed-entry-point-for-function
xep
(
fdefn-name
fdefn
)))))
;; find-typed-entry-point is called at load-time and returns the
;; fdefn that should be called.
...
...
@@ -325,10 +330,10 @@
(
cond
(
foundp
info
)
(
t
(
setf
(
ext:info
function
linkage
name
)
(
make-linkage
)))))))
(
cond
(
(
and
nil
(
dolist
(
cs
(
listify
(
linkage-callsites
linkage
)))
(
cond
((
dolist
(
cs
(
listify
(
linkage-callsites
linkage
)))
(
let*
((
ep-type
(
callsite-type
cs
)))
(
when
(
function-types-compatible-p
cs-type
ep-type
)
(
return
(
callsite-fdefn
cs
))))))
)
(
return
(
callsite-fdefn
cs
))))))
((
let
((
fdefn
(
fdefinition-object
name
nil
)))
(
when
fdefn
(
let
((
fun
(
find-typed-entry-point-for-fdefn
fdefn
)))
...
...
@@ -388,17 +393,19 @@
(
declare
(
type
function-type
ftype
))
(
let*
((
atypes
(
function-type-required
ftype
))
(
tmps
(
loop
for
nil
in
atypes
collect
(
gensym
)))
(
*derive-function-types*
nil
)
(
fun
(
compile
nil
`
(
lambda
,
tmps
(
declare
(
c::calling-convention
:typed
-no-xep
)
(
c::calling-convention
:typed
)
,@
(
loop
for
tmp
in
tmps
for
type
in
atypes
collect
`
(
type
,
(
kernel:type-specifier
type
)
,
tmp
)))
(
the
,
(
kernel:type-specifier
(
kernel:function-type-returns
ftype
))
(
funcall
(
function
,
name
)
.
,
tmps
))))))
(
funcall
',name
.
,
tmps
)))))
(
fun
(
find-typed-entry-point-for-function
fun
nil
)))
(
validate-adapter-type
fun
ftype
)
fun
))
...
...
@@ -462,27 +469,29 @@
(
defun
check-function-redefinition
(
name
new-fun
)
(
multiple-value-bind
(
linkage
foundp
)
(
ext:info
function
linkage
name
)
(
when
foundp
(
let*
((
new-code
(
function-code-header
new-fun
))
(
new-tep
(
find-typed-entry-point-in-code
new-code
name
))
(
new-type
(
extract-function-type
new-tep
)))
(
let*
((
new-tep
(
find-typed-entry-point-for-function
new-fun
name
))
(
new-type
(
if
new-tep
(
extract-function-type
new-tep
)
(
specifier-type
'
(
function
*
*
)))))
(
dolist
(
cs
(
listify
(
linkage-callsites
linkage
)))
(
let
((
cs-type
(
callsite-type
cs
))
(
fdefn
(
callsite-fdefn
cs
)))
(
cond
((
function-types-compatible-p
cs-type
new-type
)
(
cond
((
and
new-tep
(
function-types-compatible-p
cs-type
new-type
))
(
patch-fdefn
fdefn
new-tep
))
((
dolist
(
fun
(
listify
(
linkage-adapters
linkage
)))
(
let
((
ep-type
(
kernel:extract-function-type
fun
)))
(
when
(
function-types-compatible-p
cs-type
ep-type
)
(
patch-fdefn
fdefn
fun
)
(
patch-fdefn
fdefn
fun
`
(
:adapter
,
name
)
)
(
return
t
)))))
(
t
(
let
((
fun
(
generate-adapter-function
cs-type
name
)))
(
push-unlistified
fun
(
linkage-adapters
linkage
))
(
patch-fdefn
fdefn
fun
))))))))))
(
patch-fdefn
fdefn
fun
`
(
:adapter
,
name
)
))))))))))
(
defun
patch-fdefn
(
fdefn
new-fun
)
(
defun
patch-fdefn
(
fdefn
new-fun
&optional
name
)
(
setf
(
kernel:fdefn-function
fdefn
)
new-fun
)
(
let
((
name
(
kernel:%function-name
new-fun
)))
(
let
((
name
(
or
name
(
kernel:%function-name
new-fun
)))
)
(
kernel:%set-fdefn-name
fdefn
name
))
fdefn
)
...
...
src/compiler/debug.lisp
View file @
6bc8fe20
...
...
@@ -235,7 +235,8 @@
(
check-function-reached
ef
functional
)
(
unless
(
or
(
member
functional
(
optional-dispatch-entry-points
ef
))
(
eq
functional
(
optional-dispatch-more-entry
ef
))
(
eq
functional
(
optional-dispatch-main-entry
ef
)))
(
eq
functional
(
optional-dispatch-main-entry
ef
))
(
eq
functional
(
optional-dispatch-typed-entry
ef
)))
(
barf
":Optional ~S not an e-p for its OPTIONAL-DISPATCH ~S."
functional
ef
))))
(
:top-level
...
...
@@ -927,7 +928,8 @@
(
unless
(
or
(
eq
(
global-conflicts-kind
conf
)
:write
)
(
eq
tn
pc
)
(
eq
tn
fp
)
(
and
(
external-entry-point-p
fun
)
(
and
(
or
(
external-entry-point-p
fun
)
(
typed-entry-point-p
fun
))
(
tn-offset
tn
))
(
member
(
tn-kind
tn
)
'
(
:environment
:debug-environment
))
(
member
tn
vars
:key
#'
leaf-info
)
...
...
src/compiler/dump.lisp
View file @
6bc8fe20
...
...
@@ -660,7 +660,9 @@
;; flet/labels functions. We don't
;; need them stored because we can't
;; really do anything with them.
(
not
(
member
(
car
name
)
'
(
flet
labels
)
:test
'eq
)
))))
(
not
(
member
(
car
name
)
'
(
flet
labels
:typed-entry-point
)
:test
'eq
)
))))
(
dump-object
name
file
)
(
dump-push
handle
file
)
(
dump-fop
'lisp::fop-fset
file
))
...
...
src/compiler/entry.lisp
View file @
6bc8fe20
...
...
@@ -109,11 +109,9 @@
(
defun
compute-entry-info
(
fun
info
)
(
declare
(
type
clambda
fun
)
(
type
entry-info
info
))
(
let*
((
bind
(
lambda-bind
fun
))
(
internal-fun
(
functional-entry-function
fun
))
(
internal-fun
(
cond
((
typed-entry-point-p
internal-fun
)
(
functional-entry-function
internal-fun
))
(
t
internal-fun
)))
(
tep
(
typed-entry-point-p
fun
)))
(
tep
(
typed-entry-point-p
fun
))
(
internal-fun
(
cond
(
tep
(
lambda-optional-dispatch
fun
))
(
t
(
functional-entry-function
fun
)))))
(
setf
(
entry-info-closure-p
info
)
(
not
(
null
(
environment-closure
(
lambda-environment
fun
)))))
(
setf
(
entry-info-offset
info
)
(
gen-label
))
...
...
@@ -151,9 +149,6 @@
(
case
(
functional-kind
lambda
)
(
:external
(
let*
((
ef
(
functional-entry-function
lambda
))
(
ef
(
cond
((
typed-entry-point-p
ef
)
(
functional-entry-function
ef
))
(
t
ef
)))
(
new
(
make-functional
:kind
:top-level-xep
:info
(
leaf-info
lambda
)
:name
(
leaf-name
ef
)
...
...
src/compiler/envanal.lisp
View file @
6bc8fe20
...
...
@@ -57,7 +57,8 @@
(
when
(
null
(
leaf-refs
fun
))
(
let
((
kind
(
functional-kind
fun
)))
(
unless
(
or
(
eq
kind
:top-level
)
(
and
*byte-compiling*
(
eq
kind
:optional
)))
(
and
*byte-compiling*
(
eq
kind
:optional
))
(
typed-entry-point-p
fun
))
(
assert
(
member
kind
'
(
:optional
:cleanup
:escape
)))
(
setf
(
functional-kind
fun
)
nil
)
(
delete-functional
fun
)))))
...
...
src/compiler/gtn.lisp
View file @
6bc8fe20
...
...
@@ -49,14 +49,6 @@
;;; DEBUG-INFO = 3.
;;;
(
defun
assign-lambda-var-tns
(
fun
let-p
)
(
declare
(
type
clambda
fun
))
(
cond
((
typed-entry-point-p
fun
)
(
assign-typed-lambda-var-tns
fun
))
(
t
(
assign-normal-lambda-var-tns
fun
let-p
)))
(
undefined-value
))
(
defun
assign-normal-lambda-var-tns
(
fun
let-p
)
(
declare
(
type
clambda
fun
))
(
dolist
(
var
(
lambda-vars
fun
))
(
when
(
leaf-refs
var
)
...
...
@@ -72,16 +64,8 @@
(
environment-debug-live-tn
temp
(
lambda-environment
fun
)))))
(
setf
(
tn-leaf
res
)
var
)
(
setf
(
leaf-info
var
)
res
)))))
(
defun
assign-typed-lambda-var-tns
(
fun
)
(
declare
(
type
clambda
fun
))
(
let
((
ftype
(
typed-entry-point-type
fun
)))
(
loop
for
var
in
(
lambda-vars
fun
)
for
tn
in
(
make-typed-call-tns
ftype
)
do
(
when
(
leaf-refs
var
)
(
setf
(
tn-leaf
tn
)
var
)
(
setf
(
leaf-info
var
)
tn
)))))
(
setf
(
leaf-info
var
)
res
))))
(
undefined-value
))
;;; Assign-IR2-Environment -- Internal
;;;
...
...
@@ -233,17 +217,25 @@
:locations
(
mapcar
#'
make-normal-tn
ptypes
))))))
(
defun
typed-entry-point-type
(
fun
)
(
declare
(
type
clambda
fun
))
(
lambda-type
(
lambda-entry-function
fun
)))
(
declare
(
type
clambda
fun
)
(
values
function-type
))
(
let*
((
opt
(
lambda-optional-dispatch
fun
))
(
type1
(
optional-dispatch-type
opt
)))
(
typecase
type1
(
function-type
type1
)
(
t
(
lambda-type
(
optional-dispatch-main-entry
opt
))))))
(
defun
return-info-for-typed-entry-point
(
fun
)
(
declare
(
type
clambda
fun
))
(
let*
((
ftype
(
typed-entry-point-type
fun
))
(
tns
(
nth-value
1
(
make-typed-call-tns
ftype
))))
(
make-return-info
:kind
:fixed
:count
(
length
tns
)
:types
(
mapcar
#'
tn-primitive-type
tns
)
:locations
tns
)))
(
etypecase
tns
((
eql
:unknown
)
(
return-info-for-set
(
lambda-tail-set
fun
)))
(
list
(
make-return-info
:kind
:fixed
:count
(
length
tns
)
:types
(
mapcar
#'
tn-primitive-type
tns
)
:locations
tns
)))))
;;; Assign-Return-Locations -- Internal
;;;
...
...
src/compiler/ir1opt.lisp
View file @
6bc8fe20
...
...
@@ -953,9 +953,16 @@
(
info
(
ecase
cc
((
nil
)
info
)
((
:typed
:typed-no-xep
)
(
cond
((
not
info
)
(
cond
((
and
(
not
info
)
(
let
((
ftype
(
continuation-derived-type
(
combination-fun
call
))))
(
and
(
function-type-p
ftype
)
(
not
(
function-type-wild-args
ftype
)))))
(
info
function
info
'%typed-call
))
(
t
(
error
"nyi"
)))))))
(
t
;;(error "nyi")
info
))))))
(
if
info
(
values
leaf
(
setf
(
basic-combination-kind
call
)
info
))
(
values
leaf
nil
)))))))
...
...
src/compiler/ir1tran.lisp
View file @
6bc8fe20
...
...
@@ -1586,10 +1586,11 @@
(
calling-convention
(
find-declaration
'calling-convention
decls
1
0
))
(
entry-point
(
find-declaration
'entry-point
decls
1
0
))
(
res
(
if
(
or
(
find-if
#'
lambda-var-arg-info
vars
)
keyp
)
(
typed
(
eq
calling-convention
:typed
))
(
res
(
if
(
or
(
find-if
#'
lambda-var-arg-info
vars
)
keyp
typed
)
(
ir1-convert-hairy-lambda
new-body
vars
keyp
allow-other-keys
aux-vars
aux-vals
cont
)
aux-vars
aux-vals
cont
typed
)
(
ir1-convert-lambda-body
new-body
vars
aux-vars
aux-vals
t
cont
))))
(
setf
(
functional-inline-expansion
res
)
form
)
...
...
@@ -1607,7 +1608,7 @@
(
eq
'declare
(
first
decl
))
(
cons
'pcl::method
(
cadadr
decl
))))))
(
when
calling-convention
(
setf
(
getf
(
lambda
-plist
res
)
:calling-convention
)
(
setf
(
getf
(
functional
-plist
res
)
:calling-convention
)
calling-convention
))
(
when
entry-point
(
setf
(
getf
(
lambda-plist
res
)
:entry-point
)
entry-point
))
...
...
@@ -1970,7 +1971,7 @@
(
cons
arg
entry-vars
)
(
list*
t
arg-name
entry-vals
)
(
rest
vars
)
t
body
aux-vars
aux-vals
cont
)
(
ir1-convert-hairy-args
(
ir1-convert-hairy-args
res
(
cons
arg
default-vars
)
(
cons
arg-name
default-vals
)
...
...
@@ -2303,18 +2304,18 @@
nil
nil
nil
vars
supplied-p-p
body
aux-vars
aux-vals
cont
)))))))
;;; IR1-Convert-Hairy-Lambda -- Internal
;;;
;;; This function deals with the case where we have to make an
;;; Optional-Dispatch to represent a lambda. We cons up the result and call
;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the
;;; min-args and max-args.
;;; min-args and max-args.
;;;
(
defun
ir1-convert-hairy-lambda
(
body
vars
keyp
allowp
aux-vars
aux-vals
cont
)
(
defun
ir1-convert-hairy-lambda
(
body
vars
keyp
allowp
aux-vars
aux-vals
cont
typedp
)
(
declare
(
list
body
vars
aux-vars
aux-vals
)
(
type
continuation
cont
))
(
let
((
res
(
make-optional-dispatch
:arglist
vars
:allowp
allowp
:keyp
keyp
))
:keyp
keyp
:typedp
typedp
))
(
min
(
or
(
position-if
#'
lambda-var-arg-info
vars
)
(
length
vars
))))
(
push
res
(
component-new-functions
*current-component*
))
(
ir1-convert-hairy-args
res
()
()
()
()
vars
nil
body
aux-vars
aux-vals
...
...
@@ -2331,10 +2332,9 @@
(
dolist
(
ep
(
optional-dispatch-entry-points
res
))
(
frob
ep
))
(
frob
(
optional-dispatch-more-entry
res
))
(
frob
(
optional-dispatch-main-entry
res
)))
res
))
(
declaim
(
end-block
))
...
...
@@ -3994,7 +3994,9 @@
(
decls
(
nth-value
1
(
system:parse-body
(
cddr
lambda
)
*lexical-environment*
t
)))
(
convention
(
find-declaration
'calling-convention
decls
1
0
)))
(
cond
(
convention
(
cond
((
and
convention
(
not
(
info
function
info
name
))
(
and
(
null
(
lexenv-variables
*lexical-environment*
))))
(
setf
(
info
function
calling-convention
name
)
convention
))
(
t
(
clear-info
function
calling-convention
name
)))
...
...
@@ -4002,7 +4004,7 @@
;; If not in a simple environment or :notinline, then discard any forward
;; references to this function.
(
unless
expansion
(
remhash
name
*free-functions*
))
(
let*
((
var
(
get-defined-function
name
))
(
save-expansion
(
and
(
member
(
defined-function-inlinep
var
)
'
(
:inline
:maybe-inline
))
...
...
@@ -4014,7 +4016,7 @@
;; obsolete.
(
when
(
eq
(
leaf-where-from
var
)
:defined
)
(
setf
(
leaf-type
var
)
(
specifier-type
'function
)))
(
let
((
fun
(
ir1-convert-lambda-for-defun
lambda
var
expansion
#'
ir1-convert-lambda
'defun
)))
...
...
src/compiler/ir1util.lisp
View file @
6bc8fe20
...
...
@@ -916,6 +916,8 @@
(
frob
ep
))
(
when
(
optional-dispatch-more-entry
leaf
)
(
frob
(
optional-dispatch-more-entry
leaf
)))
(
when
(
optional-dispatch-typed-entry
leaf
)
(
frob
(
optional-dispatch-typed-entry
leaf
)))
(
let
((
main
(
optional-dispatch-main-entry
leaf
)))
(
when
(
eq
(
functional-kind
main
)
:optional
)
(
frob
main
))))))
...
...
src/compiler/ir2tran.lisp
View file @
6bc8fe20
...
...
@@ -903,26 +903,6 @@ compilation policy")
(
move-continuation-result
node
block
locs
cont
)))))
(
undefined-value
))
(
defun
ir2-convert-local-typed-call
(
node
block
fun
cont
)
(
declare
(
type
node
node
)
(
type
ir2-block
block
)
(
type
clambda
fun
)
(
type
continuation
cont
))
(
let
((
ftype
(
the
function-type
(
lambda-type
fun
)))
(
args
(
basic-combination-args
node
))
(
start
(
getf
(
lambda-plist
fun
)
:code-start
)))
(
multiple-value-bind
(
arg-tns
result-tns
fp
stack-frame-size
nfp
number-stack-frame-size
)
(
make-typed-call-tns
ftype
)
(
declare
(
ignore
number-stack-frame-size
))
(
let
((
cont-tns
(
loop
for
arg
in
args
collect
(
continuation-tn
node
block
arg
))))
(
vop
allocate-frame
node
block
nil
fp
nfp
)
(
vop*
typed-call-local
node
block
(
fp
nfp
(
reference-tn-list
cont-tns
nil
))
((
reference-tn-list
result-tns
t
))
arg-tns
stack-frame-size
start
)
(
move-continuation-result
node
block
result-tns
cont
)))))
;;; IR2-Convert-Local-Call -- Internal
;;;
;;; Dispatch to the appropriate function, depending on whether we have a
...
...
@@ -950,13 +930,8 @@ compilation policy")
(
:unknown
(
ir2-convert-local-unknown-call
node
block
fun
cont
start
))
(
:fixed
(
ecase
(
getf
(
lambda-plist
fun
)
:entry-point
)
((
nil
)
(
ir2-convert-local-known-call
node
block
fun
returns
cont
start
))
(
:typed
(
assert
(
external-entry-point-p
(
node-home-lambda
node
)))
(
ir2-convert-local-typed-call
node
block
fun
cont
)))))))))
(
ir2-convert-local-known-call
node
block
fun
returns
cont
start
)))))))
(
undefined-value
))
...
...
@@ -1202,16 +1177,21 @@ compilation policy")
(
undefined-value
))
;; arguments are wired to specific locations in gtn so we should have
;; to move them here.
(
defun
init-typed-entry-point-environment
(
node
block
fun
)
(
declare
(
type
bind
node
)
(
type
ir2-block
block
)
(
type
clambda
fun
))
(
let
((
start-label
(
entry-info-offset
(
leaf-info
fun
)))
(
code-label
(
getf
(
lambda-plist
fun
)
:code-start
))
(
env
(
environment-info
(
node-environment
node
))))
(
let*
((
start-label
(
entry-info-offset
(
leaf-info
fun
)))
(
code-label
(
getf
(
lambda-plist
fun
)
:code-start
))
(
env
(
environment-info
(
node-environment
node
)))
(
ftype
(
typed-entry-point-type
fun
))
(
arg-tns
(
make-typed-call-tns
ftype
)))
(
vop
typed-entry-point-allocate-frame
node
block
start-label
code-label
)
(
vop
setup-environment
node
block
start-label
)
(
loop
for
var
in
(
lambda-vars
fun
)
for
pass
in
arg-tns
do
(
when
(
leaf-refs
var
)
(
let
((
home
(
leaf-info
var
)))
(
emit-move
node
block
pass
home
))))
(
emit-move
node
block
(
make-old-fp-passing-location
t
)
(
ir2-environment-old-fp
env
))))
...
...
@@ -1780,22 +1760,38 @@ compilation policy")
(
defoptimizer
(
%typed-call
ir2-convert
)
((
&rest
args
)
node
block
)
(
let*
((
fun
(
combination-fun
node
))
(
ftype
(
continuation-derived-type
fun
))
(
cont
(
node-cont
node
)))
(
cont
(
node-cont
node
))
(
2cont
(
continuation-info
cont
)))
(
check-type
ftype
function-type
)
(
multiple-value-bind
(
arg-tns
result-tns
fp
stack-frame-size
nfp
number-stack-frame-size
)
(
make-typed-call-tns
ftype
)
(
declare
(
ignore
number-stack-frame-size
))
(
let
((
fdefn-tn
(
typed-entry-point-continuation-tn
fun
ftype
))
(
cont-tns
(
loop
for
arg
in
args
collect
(
continuation-tn
node
block
arg
))))
(
let*
((
fdefn-tn
(
typed-entry-point-continuation-tn
fun
ftype
))
(
cont-tns
(
loop
for
arg
in
args
collect
(
continuation-tn
node
block
arg
)))
(
arg-refs
(
reference-tn-list
cont-tns
nil
)))
(
vop
allocate-frame
node
block
nil
fp
nfp
)
(
vop*
typed-call-named
node
block
(
fp
nfp
fdefn-tn
(
reference-tn-list
cont-tns
nil
))
((
reference-tn-list
result-tns
t
))
arg-tns
stack-frame-size
)
(
move-continuation-result
node
block
result-tns
cont
)))))
(
cond
((
and
2cont
(
eq
(
ir2-continuation-kind
2cont
)
:unknown
)
(
eq
result-tns
:unknown
))
(
vop*
x86::multiple-typed-call-named
node
block
(
fp
nfp
fdefn-tn
arg-refs
)
((
reference-tn-list
(
ir2-continuation-locs
2cont
)
t
))
arg-tns
stack-frame-size
))
((
eq
result-tns
:unknown
)
(
let
((
locs
(
standard-result-tns
cont
)))
(
vop*
typed-call-named
node
block
(
fp
nfp
fdefn-tn
arg-refs
)
((
reference-tn-list
locs
t
))
arg-tns
stack-frame-size
(
length
locs
))
(
move-continuation-result
node
block
locs
cont
)))
(
t
(
vop*
typed-call-named
node
block
(
fp
nfp
fdefn-tn
arg-refs
)
((
reference-tn-list
result-tns
t
))
arg-tns
stack-frame-size
nil
)
(
move-continuation-result
node
block
result-tns
cont
)))))))
;;; IR2-Convert -- Interface
...
...
src/compiler/locall.lisp
View file @
6bc8fe20
...
...
@@ -145,38 +145,7 @@
(
clambda
(
let*
((
nargs
(
length
(
lambda-vars
fun
)))
(
n-supplied
(
gensym
))
(
temps
(
loop
repeat
nargs
collect
(
gensym
)))
(
fun
(
ecase
(
getf
(
lambda-plist
fun
)
:calling-convention
)
((
nil
)
fun
)
(
:typed
(
let
((
fun2
(
ir1-convert-lambda
`
(
lambda
,
temps
(
declare
(
entry-point
:typed
))
,@
(
loop
for
tmp
in
temps
for
var
in
(
lambda-vars
fun
)
collect
`
(
declare
(
type
,
(
type-specifier
(
lambda-var-type
var
))
,
tmp
)))
(
%funcall
,
fun
.
,
temps
)))))
(
setf
(
lambda-entry-function
fun
)
fun2
)
fun2
))
(
:typed-no-xep
(
return-from
make-xep-lambda
`
(
lambda
,
temps
(
declare
(
entry-point
:typed
)
,@
(
loop
for
tmp
in
temps
for
var
in
(
lambda-vars
fun
)
collect
`
(
type
,
(
type-specifier
(
lambda-var-type
var
))
,
tmp
)))
(
the
,
(
type-specifier
(
continuation-asserted-type
(
return-result
(
lambda-return
fun
))))
(
%funcall
,
fun
.
,
temps
))))))))
(
temps
(
loop
repeat
nargs
collect
(
gensym
))))
`
(
lambda
(
,
n-supplied
.
,
temps
)
(
declare
(
type
index
,
n-supplied
))
,
(
if
(
policy
nil
(
zerop
safety
))
...
...
@@ -215,6 +184,26 @@
(
%argument-count-error
,
n-supplied
)))))))))
(
defun
generate-typed-entry
(
fun
)
(
declare
(
type
optional-dispatch
fun
))
(
let*
((
main
(
optional-dispatch-main-entry
fun
))
(
temps
(
loop
for
nil
in
(
lambda-vars
main
)
collect
(
gensym
)))
(
tep
(
ir1-convert-lambda
`
(
lambda
,
temps
(
declare
(
entry-point
:typed
))
,@
(
loop
for
tmp
in
temps
for
var
in
(
lambda-vars
main
)
collect
`
(
declare
(
type
,
(
type-specifier
(
lambda-var-type
var
))
,
tmp
)))
(
%funcall
,
main
.
,
temps
)))))
(
setf
(
optional-dispatch-typed-entry
fun
)
tep
)
(
setf
(
functional-kind
tep
)
:optional
)
(
setf
(
leaf-ever-used
tep
)
t
)
(
setf
(
lambda-optional-dispatch
tep
)
fun
)))
;;; Make-External-Entry-Point -- Internal
;;;
;;; Make an external entry point (XEP) for Fun and return it. We convert
...
...
@@ -237,21 +226,19 @@
(
res
(
ir1-convert-lambda
(
make-xep-lambda
fun
))))
(
setf
(
functional-kind
res
)
:external
)
(
setf
(
leaf-ever-used
res
)
t
)
(
cond
((
functional-entry-function
fun
)
(
let
((
ep
(
functional-entry-function
fun
)))
(
setf
(
functional-entry-function
ep
)
fun
)
(
setf
(
functional-entry-function
fun
)
ep
)
(
setf
(
functional-entry-function
res
)
ep
)))
(
t
(
setf
(
functional-entry-function
res
)
fun
)
(
setf
(
functional-entry-function
fun
)
res
)))
(
setf
(
functional-entry-function
res
)
fun
)
(
setf
(
functional-entry-function
fun
)
res
)
(
setf
(
component-reanalyze
*current-component*
)
t
)
(
setf
(
component-reoptimize
*current-component*
)
t
)
(
etypecase
fun
(
clambda
(
local-call-analyze-1
fun
))
(
optional-dispatch
(
when
(
optional-dispatch-typedp
fun
)
(
generate-typed-entry
fun
))
(
dolist
(
ep
(
optional-dispatch-entry-points
fun
))
(
local-call-analyze-1
ep
))
(
when
(
optional-dispatch-typed-entry
fun
)
(
local-call-analyze-1
(
optional-dispatch-typed-entry
fun
)))