Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
d9dee664
Commit
d9dee664
authored
35 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Changed stuff for new argument passing convention.
parent
cd7aa82e
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
compiler/old-rt/call.lisp
+214
-254
214 additions, 254 deletions
compiler/old-rt/call.lisp
with
214 additions
and
254 deletions
compiler/old-rt/call.lisp
+
214
−
254
View file @
d9dee664
...
@@ -24,9 +24,8 @@
...
@@ -24,9 +24,8 @@
(
defun
standard-argument-location
(
n
)
(
defun
standard-argument-location
(
n
)
(
declare
(
type
unsigned-byte
n
))
(
declare
(
type
unsigned-byte
n
))
(
if
(
<
n
register-arg-count
)
(
if
(
<
n
register-arg-count
)
(
make-wired-tn
*any-primitive-type*
register-arg-scn
(
make-wired-tn
register-arg-scn
(
elt
register-arg-offsets
n
))
(
elt
register-arg-offsets
n
))
(
make-wired-tn
stack-arg-scn
n
)))
(
make-wired-tn
*any-primitive-type*
stack-arg-scn
n
)))
;;; Make-Return-PC-Passing-Location -- Interface
;;; Make-Return-PC-Passing-Location -- Interface
...
@@ -38,52 +37,38 @@
...
@@ -38,52 +37,38 @@
;;;
;;;
(
defun
make-return-pc-passing-location
(
standard
)
(
defun
make-return-pc-passing-location
(
standard
)
(
if
standard
(
if
standard
(
make-wired-tn
*any-primitive-type*
register-arg-scn
return-pc-offset
)
(
make-wired-tn
register-arg-scn
return-pc-offset
)
(
make-restricted-tn
*any-primitive-type*
(
list
register-arg-scn
)))
)
(
make-restricted-tn
register-arg-scn
)))
;;; Make-Old-
Cont
-Passing-Location -- Interface
;;; Make-Old-
Fp
-Passing-Location -- Interface
;;;
;;;
;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass
;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass
;;; Old-
Cont
in. This is (obviously) wired in the standard convention, but is
;;; Old-
Fp
in. This is (obviously) wired in the standard convention, but is
;;; totally unrestricted in non-standard conventions, since we can always fetch
;;; totally unrestricted in non-standard conventions, since we can always fetch
;;; it off of the stack using the arg pointer.
;;; it off of the stack using the arg pointer.
;;;
;;;
(
defun
make-old-
cont
-passing-location
(
standard
)
(
defun
make-old-
fp
-passing-location
(
standard
)
(
if
standard
(
if
standard
(
make-wired-tn
*any-primitive-type*
register-arg-scn
old-
cont
-offset
)
(
make-wired-tn
register-arg-scn
old-
fp
-offset
)
(
make-normal-tn
*any-primitive-type*
)))
(
make-normal-tn
*any-primitive-type*
)))
;;; Make-Old-
Cont
-Save-Location, Make-Return-PC-Save-Location -- Interface
;;; Make-Old-
Fp
-Save-Location, Make-Return-PC-Save-Location -- Interface
;;;
;;;
;;; Make the TNs used to hold Old-
Cont
and Return-PC within the current
;;; Make the TNs used to hold Old-
Fp
and Return-PC within the current
;;; function. We treat these specially so that the debugger can find them at a
;;; function. We treat these specially so that the debugger can find them at a
;;; known location.
;;; known location.
;;;
;;;
(
defun
make-old-
cont
-save-location
(
env
)
(
defun
make-old-
fp
-save-location
(
env
)
(
make-wired-
environment-
tn
*any-primit
ive-t
ype*
(
environment-
l
ive-t
n
stack-arg-scn
old-
cont
-save-offset
(
make-wired-tn
stack-arg-scn
old-
fp
-save-offset
)
env
))
env
))
;;;
;;;
(
defun
make-return-pc-save-location
(
env
)
(
defun
make-return-pc-save-location
(
env
)
(
make-wired-environment-tn
*any-primitive-type*
(
environment-live-tn
stack-arg-scn
return-pc-save-offset
(
make-wired-tn
stack-arg-scn
return-pc-save-offset
)
env
))
env
))
;;; Make-Argument-Pointer-Location -- Interface
;;;
;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass
;;; an argument pointer in. Even when non-standard locations are allowed, this
;;; must be restricted to a register, since the argument pointer is used to
;;; fetch stack arguments.
;;;
(
defun
make-argument-pointer-location
(
standard
)
(
if
standard
(
make-wired-tn
*any-primitive-type*
register-arg-scn
argument-pointer-offset
)
(
make-restricted-tn
*any-primitive-type*
(
list
register-arg-scn
))))
;;; Make-Argument-Count-Location -- Interface
;;; Make-Argument-Count-Location -- Interface
...
@@ -93,7 +78,16 @@
...
@@ -93,7 +78,16 @@
;;; are using non-standard conventions.
;;; are using non-standard conventions.
;;;
;;;
(
defun
make-argument-count-location
()
(
defun
make-argument-count-location
()
(
make-wired-tn
*any-primitive-type*
register-arg-scn
argument-count-offset
))
(
make-wired-tn
register-arg-scn
argument-count-offset
))
;;; MAKE-NFP-TN -- Interface
;;;
;;; Make a TN to hold the number-stack frame pointer. This is allocated
;;; once per component, and is component-live.
;;;
(
defun
make-nfp-tn
()
(
component-live-tn
(
make-restricted-tn
register-arg-scn
)))
;;; Select-Component-Format -- Interface
;;; Select-Component-Format -- Interface
...
@@ -111,58 +105,64 @@
...
@@ -111,58 +105,64 @@
(
undefined-value
))
(
undefined-value
))
;;;;
Argument/value passing, f
rame hackery:
;;;;
F
rame hackery:
;;; Fetch the argument Arg using the argument pointer Argp, yeilding the value
;;; Used for setting up the Old-Fp in local call.
;;; Val. This operation is used at function entry to move the arguments from
;;; their passing locations to the appropriate variable.
;;;
;;;
(
define-vop
(
move-argument
)
(
define-vop
(
current-fp
)
(
:args
(
arg
:scs
(
any-reg
descriptor-reg
)
:load
nil
:target
val
)
(
argp
:scs
(
descriptor-reg
)))
(
:results
(
val
:scs
(
any-reg
descriptor-reg
)))
(
:results
(
val
:scs
(
any-reg
descriptor-reg
)))
(
:generator
0
(
:generator
1
(
sc-case
arg
(
inst
lr
val
fp-tn
)))
(
stack
(
loadw
val
argp
(
tn-offset
arg
)))
((
any-reg
descriptor-reg
)
(
unless
(
location=
arg
val
)
(
inst
lr
val
arg
))))))
;;; Similar to Move-Argument, but is used to store known values into the frame
;;; being returned into. In this case, it is Loc that is potentially on the
;;; stack in a different frame.
;;;
(
define-vop
(
move-value
)
(
:args
(
value
:scs
(
any-reg
descriptor-reg
)
:target
loc
)
(
old-cont
:scs
(
descriptor-reg
)))
(
:results
(
loc
:scs
(
any-reg
descriptor-reg
)
:load
nil
))
(
:generator
0
(
sc-case
loc
(
stack
(
storew
value
old-cont
(
tn-offset
loc
)))
((
any-reg
descriptor-reg
)
(
unless
(
location=
loc
value
)
(
inst
lr
loc
value
))))))
#| Since we don't have a number stack yet, shouldn't be emitted.
;;; Used for setting up the Old-Cont in local call.
;;; Used for computing the caller's NFP for use in known-values return. Only
;;; works assuming there is no variable size stuff on the nstack.
;;;
;;;
(
define-vop
(
c
urrent-cont
)
(define-vop (c
ompute-old-nfp
)
(:results (val :scs (any-reg descriptor-reg)))
(:results (val :scs (any-reg descriptor-reg)))
(:vop-var vop)
(:generator 1
(:generator 1
(
inst
lr
val
cont-tn
)))
(let ((nfp (current-nfp-tn vop)))
(when nfp
(inst cal val nfp (- (* 4 (sb-allocated-size 'number-stack))))))))
|#
;;; Notes the place at which the environment is properly initialized, for
;;; In an XEP, allocate frames for this function on the control stack (and
;;; debug-info purposes.
;;; number stack if any). We get to emit the start label, since we might need
;;; to emit variable cruft to align it, etc.
;;;
;;;
(
define-vop
(
note-environment-start
)
(
define-vop
(
xep-allocate-frame
)
(
:info
start-lab
)
(
:info
start-lab
)
(
:generator
0
(
:generator
1
(
emit-label
start-lab
)))
(
emit-label
start-lab
)
(
inst
cal
sp-tn
fp-tn
(
*
4
(
sb-allocated-size
'stack
)))))
;;; Allocate the frame for the function we are about to call, returning the
;;; frame pointer(s).
;;;
(
define-vop
(
allocate-frame
)
(
:results
(
res
:scs
(
any-reg
descriptor-reg
))
(
nfp
))
(
:ignore
nfp
)
(
:generator
2
(
inst
lr
res
sp-tn
)
(
inst
cal
sp-tn
sp-tn
(
*
4
(
sb-allocated-size
'stack
)))))
;;; Allocate a partial frame for passing stack arguments in a full call. Nargs
;;; is the number of arguments passed. If no stack arguments are passed, then
;;; we don't have to do anything.
;;;
(
define-vop
(
allocate-full-call-frame
)
(
:info
nargs
)
(
:results
(
res
:scs
(
any-reg
descriptor-reg
)))
(
:generator
2
(
when
(
>
nargs
register-arg-count
)
(
inst
lr
res
sp-tn
)
(
inst
cal
sp-tn
sp-tn
(
*
4
nargs
)))))
;;; Default-Unknown-Values -- Internal
;;; Default-Unknown-Values -- Internal
...
@@ -204,12 +204,12 @@ regs-defaulted
...
@@ -204,12 +204,12 @@ regs-defaulted
cmpi nargs 3 ; If 4'th value unsupplied...
cmpi nargs 3 ; If 4'th value unsupplied...
blex default-value-4 ; jump to default code
blex default-value-4 ; jump to default code
loadw move-temp
args
-tn 3 ; Move value to correct location.
loadw move-temp
old-fp
-tn 3 ; Move value to correct location.
store-stack-tn val4-tn move-temp
store-stack-tn val4-tn move-temp
cmpi nargs 4 ; Check 5'th value, etc.
cmpi nargs 4 ; Check 5'th value, etc.
blex default-value-5
blex default-value-5
loadw move-temp
args
-tn 4
loadw move-temp
old-fp
-tn 4
store-stack-tn val5-tn move-temp
store-stack-tn val5-tn move-temp
...
...
...
@@ -235,7 +235,7 @@ default-value-5
...
@@ -235,7 +235,7 @@ default-value-5
(
type
unsigned-byte
nvals
)
(
type
tn
move-temp
nil-temp
))
(
type
unsigned-byte
nvals
)
(
type
tn
move-temp
nil-temp
))
(
assemble
node
(
assemble
node
(
if
(
<=
nvals
1
)
(
if
(
<=
nvals
1
)
(
inst
ai
sp-tn
args
-tn
0
)
(
inst
ai
sp-tn
old-fp
-tn
0
)
(
let
((
regs-defaulted
(
gen-label
))
(
let
((
regs-defaulted
(
gen-label
))
(
defaulting-done
(
gen-label
)))
(
defaulting-done
(
gen-label
)))
(
inst
bnb
:pz
regs-defaulted
)
(
inst
bnb
:pz
regs-defaulted
)
...
@@ -246,7 +246,7 @@ default-value-5
...
@@ -246,7 +246,7 @@ default-value-5
(
inst
cau
(
tn-ref-tn
val
)
zero-tn
clc::nil-16
))
(
inst
cau
(
tn-ref-tn
val
)
zero-tn
clc::nil-16
))
(
when
(
>
nvals
register-arg-count
)
(
when
(
>
nvals
register-arg-count
)
(
loadi
nargs-tn
1
)
(
loadi
nargs-tn
1
)
(
inst
lr
args
-tn
sp-tn
))
(
inst
lr
old-fp
-tn
sp-tn
))
(
emit-label
regs-defaulted
)
(
emit-label
regs-defaulted
)
...
@@ -266,11 +266,11 @@ default-value-5
...
@@ -266,11 +266,11 @@ default-value-5
(
defaults
(
cons
default-lab
tn
))
(
defaults
(
cons
default-lab
tn
))
(
cmpi
nargs-tn
i
)
(
cmpi
nargs-tn
i
)
(
inst
bnbx
:gt
default-lab
)
(
inst
bnbx
:gt
default-lab
)
(
loadw
move-temp
args
-tn
i
)
(
loadw
move-temp
old-fp
-tn
i
)
(
store-stack-tn
tn
move-temp
)))
(
store-stack-tn
tn
move-temp
)))
(
emit-label
defaulting-done
)
(
emit-label
defaulting-done
)
(
inst
lr
sp-tn
args
-tn
)
(
inst
lr
sp-tn
old-fp
-tn
)
(
unassemble
(
unassemble
(
assemble-elsewhere
node
(
assemble-elsewhere
node
...
@@ -340,7 +340,7 @@ default-value-5
...
@@ -340,7 +340,7 @@ default-value-5
(
count
:scs
(
descriptor-reg
)))
(
count
:scs
(
descriptor-reg
)))
(
:node-var
node
)
(
:node-var
node
)
(
:temporary
(
:sc
descriptor-reg
(
:temporary
(
:sc
descriptor-reg
:offset
argument-pointer
-offset
:offset
old-fp
-offset
:from
:eval
:to
(
:result
0
))
:from
:eval
:to
(
:result
0
))
values-start
)
values-start
)
(
:temporary
(
:sc
any-reg
(
:temporary
(
:sc
any-reg
...
@@ -348,29 +348,16 @@ default-value-5
...
@@ -348,29 +348,16 @@ default-value-5
:from
:eval
:to
(
:result
1
))
:from
:eval
:to
(
:result
1
))
nvals
))
nvals
))
;;;; Tail-recursive local call:
;;; We just do the control transfer. The other stuff is done with explicit
;;; move VOPs.
;;;
(
define-vop
(
tail-call-local
)
(
:args
(
args
:more
t
))
(
:info
start
)
(
:ignore
args
)
(
:generator
5
(
when
start
(
inst
bnb
:pz
start
))))
;;;; Local call with unknown values convention return:
;;;; Local call with unknown values convention return:
;;; Non-TR local call for a fixed number of values passed according to the
;;; Non-TR local call for a fixed number of values passed according to the
;;; unknown values convention.
;;; unknown values convention.
;;;
;;;
;;; Args are the argument passing locations, which are specified only to
;;; When initially emitted, Args reference the values to be passed.
;;; terminate their lifetimes in the caller.
;;; Representation selection changes the Args to reference the passing
;;; locations when it inserts the move-argument VOPs. Arg-Locs is the list of
;;; passing locations used by representation selection.
;;;
;;;
;;; Values are the return value locations (wired to the standard passing
;;; Values are the return value locations (wired to the standard passing
;;; locations).
;;; locations).
...
@@ -381,11 +368,14 @@ default-value-5
...
@@ -381,11 +368,14 @@ default-value-5
;;; Nvals is the number of values received.
;;; Nvals is the number of values received.
;;;
;;;
(
define-vop
(
call-local
)
(
define-vop
(
call-local
)
(
:args
(
args
:more
t
))
(
:args
(
fp
:scs
(
any-reg
descriptor-reg
))
(
nfp
)
(
args
:more
t
))
(
:results
(
values
:more
t
))
(
:results
(
values
:more
t
))
(
:save-p
t
)
(
:save-p
t
)
(
:info
save
return-pc
target
nvals
)
(
:move-args
:local-call
)
(
:ignore
args
save
)
(
:info
arg-locs
return-pc
target
nvals
)
(
:ignore
arg-locs
args
nfp
)
(
:node-var
node
)
(
:node-var
node
)
(
:vop-var
vop
)
(
:vop-var
vop
)
(
:temporary
(
:scs
(
descriptor-reg
))
move-temp
nil-temp
)
(
:temporary
(
:scs
(
descriptor-reg
))
move-temp
nil-temp
)
...
@@ -394,9 +384,9 @@ default-value-5
...
@@ -394,9 +384,9 @@ default-value-5
env-save
)
env-save
)
(
:generator
5
(
:generator
5
(
store-stack-tn
env-save
env-tn
)
(
store-stack-tn
env-save
env-tn
)
(
inst
lr
cont-tn
sp-tn
)
(
inst
balix
return-pc
target
)
(
inst
balix
return-pc
target
)
(
inst
cal
sp-tn
sp-tn
(
current-frame-size
))
(
inst
lr
fp-tn
fp
)
(
no-op
)
(
note-this-location
vop
:unknown-return
)
(
note-this-location
vop
:unknown-return
)
(
unassemble
(
unassemble
(
default-unknown-values
node
values
nvals
move-temp
nil-temp
))
(
default-unknown-values
node
values
nvals
move-temp
nil-temp
))
...
@@ -408,19 +398,22 @@ default-value-5
...
@@ -408,19 +398,22 @@ default-value-5
;;; glob and the number of values received.
;;; glob and the number of values received.
;;;
;;;
(
define-vop
(
multiple-call-local
unknown-values-receiver
)
(
define-vop
(
multiple-call-local
unknown-values-receiver
)
(
:args
(
args
:more
t
))
(
:args
(
fp
:scs
(
any-reg
descriptor-reg
))
(
nfp
)
(
args
:more
t
))
(
:save-p
t
)
(
:save-p
t
)
(
:info
save
return-pc
target
)
(
:move-args
:local-call
)
(
:ignore
args
save
)
(
:info
arg-locs
return-pc
target
)
(
:ignore
arg-locs
args
nfp
)
(
:vop-var
vop
)
(
:vop-var
vop
)
(
:temporary
(
:sc
stack
(
:temporary
(
:sc
stack
:offset
env-save-offset
)
:offset
env-save-offset
)
env-save
)
env-save
)
(
:generator
20
(
:generator
20
(
store-stack-tn
env-save
env-tn
)
(
store-stack-tn
env-save
env-tn
)
(
inst
lr
cont-tn
sp-tn
)
(
inst
balix
return-pc
target
)
(
inst
balix
return-pc
target
)
(
inst
cal
sp-tn
sp-tn
(
current-frame-size
))
(
inst
lr
fp-tn
fp
)
(
no-op
)
(
note-this-location
vop
:unknown-return
)
(
note-this-location
vop
:unknown-return
)
(
unassemble
(
unassemble
(
receive-unknown-values
node
values-start
nvals
start
count
))
(
receive-unknown-values
node
values-start
nvals
start
count
))
...
@@ -433,35 +426,39 @@ default-value-5
...
@@ -433,35 +426,39 @@ default-value-5
;;; just like argument passing in local call.
;;; just like argument passing in local call.
;;;
;;;
(
define-vop
(
known-call-local
)
(
define-vop
(
known-call-local
)
(
:args
(
:args
(
fp
:scs
(
any-reg
descriptor-reg
))
(
args
:more
t
))
(
nfp
)
(
args
:more
t
))
(
:results
(
:results
(
res
:more
t
))
(
res
:more
t
))
(
:move-args
:local-call
)
(
:save-p
t
)
(
:save-p
t
)
(
:info
save
return-pc
target
)
(
:info
arg-locs
return-pc
target
)
(
:ignore
arg
s
res
save
)
(
:ignore
arg
-locs
args
res
nfp
)
(
:vop-var
vop
)
(
:vop-var
vop
)
(
:generator
5
(
:generator
5
(
inst
lr
cont-tn
sp-tn
)
(
inst
balix
return-pc
target
)
(
inst
balix
return-pc
target
)
(
inst
cal
sp-tn
sp-tn
(
current-frame-size
))
(
inst
lr
fp-tn
fp
)
(
no-op
)
(
note-this-location
vop
:known-return
)))
(
note-this-location
vop
:known-return
)))
;;; Return from known values call. We receive the return locations as
;;; Return from known values call. We receive the return locations as
;;; arguments to terminate their lifetimes in the returning function. We
;;; arguments to terminate their lifetimes in the returning function. We
;;; restore
CONT
and SP and jump to the Return-PC.
;;; restore
FP
and SP and jump to the Return-PC.
;;;
;;;
(
define-vop
(
known-return
)
(
define-vop
(
known-return
)
(
:args
(
:args
(
old-
cont
:scs
(
descriptor-reg
))
(
old-
fp
:scs
(
descriptor-reg
))
(
return-pc
:scs
(
descriptor-reg
))
(
return-pc
:scs
(
descriptor-reg
))
(
locs
:more
t
))
(
vals
:more
t
))
(
:ignore
locs
)
(
:move-args
:known-return
)
(
:info
val-locs
)
(
:ignore
val-locs
vals
)
(
:generator
6
(
:generator
6
(
inst
lr
sp-tn
cont
-tn
)
(
inst
lr
sp-tn
fp
-tn
)
(
inst
bnbrx
:pz
return-pc
)
(
inst
bnbrx
:pz
return-pc
)
(
inst
lr
cont
-tn
old-
cont
)))
(
inst
lr
fp
-tn
old-
fp
)))
;;;; Full call:
;;;; Full call:
...
@@ -470,10 +467,12 @@ default-value-5
...
@@ -470,10 +467,12 @@ default-value-5
;;; versions are used depending on whether we know the number of arguments or
;;; versions are used depending on whether we know the number of arguments or
;;; the name of the called function, and whether we want fixed values, unknown
;;; the name of the called function, and whether we want fixed values, unknown
;;; values, or a tail call.
;;; values, or a tail call.
;;;
;;; In full call, the arguments are passed by placing them in TNs wired to the
;;; In full call, the arguments are passed creating a partial frame on the
;;; beginning of the current frame (as done by Standard-Argument-Location). A
;;; stack top and storing stack arguments into that frame. On entry to the
;;; pointer to these arguments is then passed as the argument pointer.
;;; callee, this partial frame is pointed to by FP. If there are no stack
;;; arguments, we don't bother allocating a partial frame, and instead set FP
;;; to SP just before the call.
;;; Define-Full-Call -- Internal
;;; Define-Full-Call -- Internal
...
@@ -493,14 +492,17 @@ default-value-5
...
@@ -493,14 +492,17 @@ default-value-5
;;; result values are specified by the Start and Count as in the
;;; result values are specified by the Start and Count as in the
;;; unknown-values continuation representation.
;;; unknown-values continuation representation.
;;; -- If :Tail, then do a tail-recursive call. No values are returned.
;;; -- If :Tail, then do a tail-recursive call. No values are returned.
;;; The Old-Cont and Return-PC are passed as the second and third arguments.
;;; The Old-Fp and Return-PC are passed as the second and third arguments.
;;;
;;; In non-tail calls, the pointer to the stack arguments is passed as the last
;;; fixed argument. If Variable is false, then the passing locations are
;;; passed as a more arg. Variable is true if there are a variable number of
;;; arguments passed on the stack. Variable cannot be specified with :Tail
;;; return. TR variable argument call is implemented separately.
;;;
;;;
;;; Variable is true if there are a variable number of arguments passed on the
;;; In tail call with fixed arguments, the passing locations are passed as a
;;; stack, with the last argument pointing to the beginning of the arguments.
;;; more arg, but there is no new-FP, since the arguments have been set up in
;;; If Variable is false, the arguments are set up in the standard passing
;;; the current frame.
;;; locations and are passed as the remaining arguments. Variable cannot be
;;; specified with :Tail return. TR variable argument call is implemented
;;; separately.
;;;
;;;
(
defmacro
define-full-call
(
name
named
return
variable
)
(
defmacro
define-full-call
(
name
named
return
variable
)
(
assert
(
not
(
and
variable
(
eq
return
:tail
))))
(
assert
(
not
(
and
variable
(
eq
return
:tail
))))
...
@@ -508,47 +510,47 @@ default-value-5
...
@@ -508,47 +510,47 @@ default-value-5
,@
(
when
(
eq
return
:unknown
)
,@
(
when
(
eq
return
:unknown
)
'
(
unknown-values-receiver
)))
'
(
unknown-values-receiver
)))
(
:args
(
:args
,@
(
unless
(
eq
return
:tail
)
'
((
new-fp
:scs
(
descriptor-reg
)
:to
:eval
)))
,
(
if
named
,
(
if
named
'
(
name
:scs
(
descriptor-reg
)
'
(
name
:scs
(
descriptor-reg
)
:target
name-pass
)
:target
name-pass
)
'
(
arg-fun
:scs
(
descriptor-reg
)
'
(
function
:scs
(
descriptor-reg
)
:to
:eval
))
:target
function
))
,@
(
when
(
eq
return
:tail
)
,@
(
when
(
eq
return
:tail
)
'
((
old-
cont
:scs
(
descriptor-reg
)
'
((
old-
fp
:scs
(
descriptor-reg
)
:target
old-
cont
-pass
)
:target
old-
fp
-pass
)
(
return-pc
:scs
(
descriptor-reg
)
(
return-pc
:scs
(
descriptor-reg
)
:target
return-pc-pass
)))
:target
return-pc-pass
)))
,
(
if
variable
,@
(
unless
variable
'
((
args
:more
t
))))
'
(
args
:scs
(
descriptor-reg
)
:target
args-pass
)
'
(
args
:more
t
)))
,@
(
when
(
eq
return
:fixed
)
,@
(
when
(
eq
return
:fixed
)
'
((
:results
(
values
:more
t
))))
'
((
:results
(
values
:more
t
))))
,@
(
unless
(
eq
return
:tail
)
,@
(
unless
(
eq
return
:tail
)
'
((
:save-p
t
)
`
((
:save-p
t
)
(
:node-var
node
)
(
:node-var
node
)
(
:vop-var
vop
)
(
:vop-var
vop
)
(
:temporary
(
:sc
stack
(
:temporary
(
:sc
stack
:offset
env-save-offset
)
:offset
env-save-offset
)
env-save
)))
env-save
)
,@
(
unless
variable
'
((
:move-args
:full-call
)))))
(
:info
,@
(
unless
(
eq
return
:tail
)
'
(
save
))
(
:info
,@
(
unless
(
or
variable
(
eq
return
:tail
)
)
'
(
arg-locs
))
,@
(
unless
variable
'
(
nargs
))
,@
(
unless
variable
'
(
nargs
))
,@
(
when
(
eq
return
:fixed
)
'
(
nvals
)))
,@
(
when
(
eq
return
:fixed
)
'
(
nvals
)))
(
:ignore
(
:ignore
,@
(
unless
(
or
variable
(
eq
return
:tail
))
'
(
arg-locs
))
,@
(
unless
(
eq
return
:tail
)
'
(
save
))
,@
(
unless
variable
'
(
args
)))
,@
(
unless
variable
'
(
args
)))
(
:temporary
(
:sc
descriptor-reg
(
:temporary
(
:sc
descriptor-reg
:offset
old-
cont
-offset
:offset
old-
fp
-offset
:from
(
:argument
,
(
if
(
eq
return
:tail
)
1
0
))
:from
(
:argument
,
(
if
(
eq
return
:tail
)
1
0
))
:to
:eval
)
:to
:eval
)
old-
cont
-pass
)
old-
fp
-pass
)
(
:temporary
(
:sc
descriptor-reg
(
:temporary
(
:sc
descriptor-reg
:offset
return-pc-offset
:offset
return-pc-offset
...
@@ -561,18 +563,11 @@ default-value-5
...
@@ -561,18 +563,11 @@ default-value-5
:offset
call-name-offset
:offset
call-name-offset
:from
(
:argument
0
)
:from
(
:argument
0
)
:to
:eval
)
:to
:eval
)
name-pass
)))
name-pass
)
(
:temporary
(
:scs
(
descriptor-reg
)
(
:temporary
(
:scs
(
descriptor-reg
)
:from
(
:argument
0
)
:from
(
:argument
0
)
:to
:eval
)
:to
:eval
)
function
)))
function
)
(
:temporary
(
:sc
descriptor-reg
:offset
argument-pointer-offset
:from
(
:argument
,
(
if
variable
1
0
))
:to
:eval
)
args-pass
)
(
:temporary
(
:sc
descriptor-reg
(
:temporary
(
:sc
descriptor-reg
:offset
argument-count-offset
:offset
argument-count-offset
...
@@ -608,39 +603,38 @@ default-value-5
...
@@ -608,39 +603,38 @@ default-value-5
15
15
(
if
(
eq
return
:unknown
)
25
0
))
(
if
(
eq
return
:unknown
)
25
0
))
,@
(
if
named
,@
(
when
named
`
((
unless
(
location=
name
name-pass
)
`
((
unless
(
location=
name
name-pass
)
(
inst
lr
name-pass
name
))
(
inst
lr
name-pass
name
))
(
loadw
function
name-pass
(
/
clc::symbol-definition
4
)))
(
loadw
function
name-pass
(
/
clc::symbol-definition
4
))))
`
((
unless
(
location=
arg-fun
function
)
(
inst
lr
function
arg-fun
))))
,@
(
if
variable
,@
(
if
variable
`
((
unless
(
location=
args
args-pass
)
`
((
inst
lr
nargs-pass
sp-tn
)
(
inst
lr
args-pass
args
))
(
inst
s
nargs-pass
new-fp
)
(
inst
lr
nargs-pass
sp-tn
)
(
inst
s
nargs-pass
args-pass
)
(
inst
sari
nargs-pass
2
)
(
inst
sari
nargs-pass
2
)
(
loadw
a0
args-pass
0
)
(
loadw
a0
new-fp
0
)
(
loadw
a1
args-pass
1
)
(
loadw
a1
new-fp
1
)
(
loadw
a2
args-pass
2
))
(
loadw
a2
new-fp
2
))
`
((
loadi
nargs-pass
nargs
)
`
((
loadi
nargs-pass
nargs
)))
(
inst
lr
args-pass
cont-tn
)))
(
load-slot
code
function
system:%function-code-slot
)
(
load-slot
code
function
system:%function-code-slot
)
(
load-slot
offset
function
system:%function-offset-slot
)
(
load-slot
offset
function
system:%function-offset-slot
)
(
inst
cas
code
code
offset
)
(
inst
cas
code
code
offset
)
,@
(
if
(
eq
return
:tail
)
,@
(
if
(
eq
return
:tail
)
'
((
unless
(
location=
old-
cont
old-
cont
-pass
)
'
((
unless
(
location=
old-
fp
old-
fp
-pass
)
(
inst
lr
old-
cont
-pass
old-
cont
))
(
inst
lr
old-
fp
-pass
old-
fp
))
(
unless
(
location=
return-pc
return-pc-pass
)
(
unless
(
location=
return-pc
return-pc-pass
)
(
inst
lr
return-pc-pass
return-pc
))
(
inst
lr
return-pc-pass
return-pc
))
(
inst
bnbrx
:pz
code
)
(
inst
bnbrx
:pz
code
)
(
inst
lr
env-tn
function
))
(
inst
lr
env-tn
function
))
'
((
store-stack-tn
env-save
env-tn
)
`
((
store-stack-tn
env-save
env-tn
)
(
inst
lr
old-cont-pass
cont-tn
)
(
inst
lr
old-fp-pass
fp-tn
)
(
inst
lr
cont-tn
sp-tn
)
,
(
if
variable
'
(
inst
lr
fp-tn
new-fp
)
'
(
if
(
>
nargs
register-arg-count
)
(
inst
lr
fp-tn
new-fp
)
(
inst
lr
fp-tn
sp-tn
)))
(
inst
balrx
return-pc-pass
code
)
(
inst
balrx
return-pc-pass
code
)
(
inst
lr
env-tn
function
)
(
inst
lr
env-tn
function
)
(
no-op
)))
(
no-op
)))
...
@@ -675,43 +669,41 @@ default-value-5
...
@@ -675,43 +669,41 @@ default-value-5
;;; down.
;;; down.
;;;
;;;
;;; This miscop uses a non-standard calling convention so that the argument
;;; This miscop uses a non-standard calling convention so that the argument
;;; registers are free for loading of stack arguments. Old-Cont, Args and the
;;; registers are free for loading of stack arguments. Old-Fp and the function
;;; function are passed in the registers that they will ultimately go in:
;;; are passed in the registers that they will ultimately go in: OLD-FP and
;;; OLD-CONT, ARGS and ENV. The Return-PC is passed in A3 rather than PC
;;; ENV. Args is a pointer to the start of the arguments on the stack, and is
;;; because the BALA trashes PC. We use BALA even though the miscop never
;;; passed in the special ARGS passing location. The Return-PC is passed in
;;; returns, since there isn't any BA.
;;; A3 rather than PC because the BALA trashes PC. We use BALA even though the
;;; miscop never returns, since there isn't any BA.
;;;
;;;
;;; [### We could easily code inline the special case of nargs <= 3.]
;;; [### We could easily code inline the special case of nargs <= 3.]
;;;
;;;
(
define-vop
(
tail-call-variable
)
(
define-vop
(
tail-call-variable
)
(
:args
(
:args
(
args
:scs
(
descriptor-reg
)
:target
args-pass
)
(
function
:scs
(
descriptor-reg
))
(
function
:scs
(
descriptor-reg
))
(
old-cont
:scs
(
descriptor-reg
)
(
old-fp
:scs
(
descriptor-reg
)
:target
old-fp-pass
)
:target
old-cont-pass
)
(
return-pc
:scs
(
descriptor-reg
)
:target
a3
))
(
return-pc
:scs
(
descriptor-reg
)
:target
a3
)
(
args
:scs
(
descriptor-reg
)
:target
args-pass
))
(
:temporary
(
:sc
descriptor-reg
(
:temporary
(
:sc
descriptor-reg
:offset
old-
cont
-offset
:offset
old-
fp
-offset
:from
(
:argument
1
))
:from
(
:argument
2
))
old-
cont
-pass
)
old-
fp
-pass
)
(
:temporary
(
:sc
descriptor-reg
(
:temporary
(
:sc
descriptor-reg
:offset
a3-offset
:offset
a3-offset
:from
(
:argument
2
))
:from
(
:argument
3
))
a3
)
a3
)
(
:temporary
(
:sc
descriptor-reg
(
:temporary
(
:sc
descriptor-reg
:offset
argument-pointer-offset
:offset
argument-pointer-offset
:from
(
:argument
3
))
:from
(
:argument
0
))
args-pass
)
args-pass
)
(
:generator
75
(
:generator
75
(
inst
lr
env-tn
function
)
(
inst
lr
env-tn
function
)
(
unless
(
location=
old-cont
old-cont-pass
)
(
inst
lr
old-cont-pass
old-cont
))
(
unless
(
location=
return-pc
a3
)
(
inst
lr
a3
return-pc
))
(
unless
(
location=
args
args-pass
)
(
unless
(
location=
args
args-pass
)
(
inst
lr
args-pass
args
))
(
inst
lr
args-pass
args
))
(
unless
(
location=
old-fp
old-fp-pass
)
(
inst
lr
old-fp-pass
old-fp
))
(
unless
(
location=
return-pc
a3
)
(
inst
lr
a3
return-pc
))
(
inst
miscop
'clc::tail-call-variable
)))
(
inst
miscop
'clc::tail-call-variable
)))
...
@@ -723,17 +715,17 @@ default-value-5
...
@@ -723,17 +715,17 @@ default-value-5
;;; number of values returned.
;;; number of values returned.
;;;
;;;
;;; If returning a single value, then deallocate the current frame, restore
;;; If returning a single value, then deallocate the current frame, restore
;;;
CONT
and jump to the single-value entry at Return-PC + 4.
;;;
FP
and jump to the single-value entry at Return-PC + 4.
;;;
;;;
;;; If returning other than one value, then load the number of values returned,
;;; If returning other than one value, then load the number of values returned,
;;; NIL out unsupplied values registers, restore
CONT
and return at Return-PC.
;;; NIL out unsupplied values registers, restore
FP
and return at Return-PC.
;;; When there are stack values, we must initialize the argument pointer to
;;; When there are stack values, we must initialize the argument pointer to
;;; point to the beginning of the values block (which is the beginning of the
;;; point to the beginning of the values block (which is the beginning of the
;;; current frame.)
;;; current frame.)
;;;
;;;
(
define-vop
(
return
)
(
define-vop
(
return
)
(
:args
(
:args
(
old-
cont
:scs
(
descriptor-reg
any-reg
))
(
old-
fp
:scs
(
descriptor-reg
any-reg
))
(
return-pc
:scs
(
descriptor-reg
)
:target
pc-save
)
(
return-pc
:scs
(
descriptor-reg
)
:target
pc-save
)
(
values
:more
t
))
(
values
:more
t
))
(
:ignore
values
)
(
:ignore
values
)
...
@@ -758,19 +750,19 @@ default-value-5
...
@@ -758,19 +750,19 @@ default-value-5
:offset
argument-count-offset
)
:offset
argument-count-offset
)
nvals-loc
)
nvals-loc
)
(
:temporary
(
:sc
descriptor-reg
(
:temporary
(
:sc
descriptor-reg
:offset
argument-pointer
-offset
)
:offset
old-fp
-offset
)
vals-loc
)
vals-loc
)
(
:generator
6
(
:generator
6
(
cond
((
=
nvals
1
)
(
cond
((
=
nvals
1
)
(
inst
lr
sp-tn
cont
-tn
)
(
inst
lr
sp-tn
fp
-tn
)
(
inst
inc
return-pc
4
)
(
inst
inc
return-pc
4
)
(
inst
bnbrx
:pz
return-pc
)
(
inst
bnbrx
:pz
return-pc
)
(
inst
lr
cont
-tn
old-
cont
))
(
inst
lr
fp
-tn
old-
fp
))
(
t
(
t
(
loadi
nvals-loc
nvals
)
(
loadi
nvals-loc
nvals
)
(
inst
lr
vals-loc
cont
-tn
)
(
inst
lr
vals-loc
fp
-tn
)
(
inst
cal
sp-tn
vals-loc
(
*
nvals
4
))
(
inst
cal
sp-tn
vals-loc
(
*
nvals
4
))
(
inst
lr
cont
-tn
old-
cont
)
(
inst
lr
fp
-tn
old-
fp
)
(
unless
(
location=
pc-save
return-pc
)
(
unless
(
location=
pc-save
return-pc
)
(
inst
lr
pc-save
return-pc
))
(
inst
lr
pc-save
return-pc
))
...
@@ -792,14 +784,15 @@ default-value-5
...
@@ -792,14 +784,15 @@ default-value-5
;;;
;;;
;;; The Return-Multiple miscop uses a non-standard calling convention. For one
;;; The Return-Multiple miscop uses a non-standard calling convention. For one
;;; thing, it doesn't return. We only use BALA because there isn't a BA
;;; thing, it doesn't return. We only use BALA because there isn't a BA
;;; instruction.
Also, we don't use A0..A2 for argument passing, since the
;;; instruction. Also, we don't use A0..A2 for argument passing, since the
;;; miscop will want to load these with values off of the stack. Instead, we
;;; miscop will want to load these with values off of the stack. Instead, we
;;; pass Old-Cont, Start and Count in the normal locations for these values.
;;; pass Old-Fp and Count in the normal locations for these values. The
;;; Return-PC is passed in A3 since PC is trashed by the BALA.
;;; pointer to the start of the return values is passed in the special ARGS
;;; location. Return-PC is passed in A3 since PC is trashed by the BALA.
;;;
;;;
(
define-vop
(
return-multiple
)
(
define-vop
(
return-multiple
)
(
:args
(
:args
(
old-
cont
:scs
(
descriptor-reg
)
:target
old-
cont
-pass
)
(
old-
fp
:scs
(
descriptor-reg
)
:target
old-
fp
-pass
)
(
return-pc
:scs
(
descriptor-reg
)
(
return-pc
:scs
(
descriptor-reg
)
:target
a3
)
:target
a3
)
(
start
:scs
(
descriptor-reg
)
(
start
:scs
(
descriptor-reg
)
...
@@ -807,9 +800,9 @@ default-value-5
...
@@ -807,9 +800,9 @@ default-value-5
(
count
:scs
(
descriptor-reg
)
(
count
:scs
(
descriptor-reg
)
:target
nvals-loc
))
:target
nvals-loc
))
(
:temporary
(
:sc
descriptor-reg
(
:temporary
(
:sc
descriptor-reg
:offset
old-
cont
-offset
:offset
old-
fp
-offset
:from
(
:argument
0
))
:from
(
:argument
0
))
old-
cont
-pass
)
old-
fp
-pass
)
(
:temporary
(
:sc
descriptor-reg
(
:temporary
(
:sc
descriptor-reg
:offset
a3-offset
:offset
a3-offset
:from
(
:argument
1
))
:from
(
:argument
1
))
...
@@ -831,16 +824,16 @@ default-value-5
...
@@ -831,16 +824,16 @@ default-value-5
(
cmpi
count
1
)
(
cmpi
count
1
)
(
inst
bnbx
:eq
non-single
)
(
inst
bnbx
:eq
non-single
)
(
loadw
a0
start
)
(
loadw
a0
start
)
(
inst
lr
sp-tn
cont
-tn
)
(
inst
lr
sp-tn
fp
-tn
)
(
inst
inc
return-pc
4
)
(
inst
inc
return-pc
4
)
(
inst
bnbrx
:pz
return-pc
)
(
inst
bnbrx
:pz
return-pc
)
(
inst
lr
cont
-tn
old-
cont
)
(
inst
lr
fp
-tn
old-
fp
)
(
unassemble
(
unassemble
(
assemble-elsewhere
node
(
assemble-elsewhere
node
(
emit-label
non-single
)
(
emit-label
non-single
)
(
unless
(
location=
old-
cont
-pass
old-
cont
)
(
unless
(
location=
old-
fp
-pass
old-
fp
)
(
inst
lr
old-
cont
-pass
old-
cont
))
(
inst
lr
old-
fp
-pass
old-
fp
))
(
unless
(
location=
a3
return-pc
)
(
unless
(
location=
a3
return-pc
)
(
inst
lr
a3
return-pc
))
(
inst
lr
a3
return-pc
))
(
unless
(
location=
vals-loc
start
)
(
unless
(
location=
vals-loc
start
)
...
@@ -852,17 +845,6 @@ default-value-5
...
@@ -852,17 +845,6 @@ default-value-5
;;;; XEP hackery:
;;;; XEP hackery:
;;; We get to emit the start label, since we might need to emit variable cruft
;;; to align it, etc.
;;;
(
define-vop
(
allocate-frame
)
(
:info
start-lab
)
(
:generator
1
(
emit-label
start-lab
)
(
inst
cal
sp-tn
cont-tn
(
current-frame-size
))))
;;; Fetch the constant pool from the function entry structure.
;;; Fetch the constant pool from the function entry structure.
;;;
;;;
(
define-vop
(
setup-environment
)
(
define-vop
(
setup-environment
)
...
@@ -906,32 +888,10 @@ default-value-5
...
@@ -906,32 +888,10 @@ default-value-5
(
:translate
%more-arg
))
(
:translate
%more-arg
))
;;; Turn more arg (context, count) into a list. Context and count are passed
;;; Turn more arg (context, count) into a list.
;;; in ARGS and NARGS.
;;;
;;;
(
define-vop
(
listify-rest-args
zero-arg-miscop
)
(
define-miscop
listify-rest-args
(
context
count
)
(
:args
(
context
:target
args
:scs
(
any-reg
descriptor-reg
))
:translate
%listify-rest-args
)
(
count
:target
nargs
:scs
(
any-reg
descriptor-reg
)))
(
:temporary
(
:sc
any-reg
:offset
argument-pointer-offset
:from
(
:argument
0
)
:to
:eval
)
args
)
(
:temporary
(
:sc
any-reg
:offset
argument-count-offset
:from
(
:argument
1
)
:to
:eval
)
nargs
)
(
:variant-vars
)
(
:translate
%listify-rest-args
)
(
:generator
50
(
unless
(
location=
context
args
)
(
inst
lr
args
context
))
(
unless
(
location=
count
nargs
)
(
inst
lr
nargs
count
))
(
inst
miscop
'clc::listify-rest-args
)
(
unless
(
location=
a0
r
)
(
inst
lr
r
a0
))))
;;; Return the location and size of the more arg glob created by Copy-More-Arg.
;;; Return the location and size of the more arg glob created by Copy-More-Arg.
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
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!
Save comment
Cancel
Please
register
or
sign in
to comment