Skip to content
Snippets Groups Projects
Commit d9dee664 authored by ram's avatar ram
Browse files

Changed stuff for new argument passing convention.

parent cd7aa82e
No related branches found
No related tags found
No related merge requests found
...@@ -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-primitive-type* (environment-live-tn
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, frame hackery: ;;;; Frame 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 (current-cont) (define-vop (compute-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 args 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.
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment