- (defaulting-done (gen-label))
- (default-stack-vals (gen-label)))
- ;; Branch off to the MV case.
- (sb!assem:without-scheduling ()
- (note-this-location vop :unknown-return)
- (if (> nvals register-arg-count)
- (inst addic. temp nargs-tn (- (fixnumize register-arg-count)))
- (move csp-tn ocfp-tn))
- (inst b regs-defaulted))
-
- ;; Do the single value case.
- (do ((i 1 (1+ i))
- (val (tn-ref-across values) (tn-ref-across val)))
- ((= i (min nvals register-arg-count)))
- (move (tn-ref-tn val) null-tn))
- (when (> nvals register-arg-count)
- (move ocfp-tn csp-tn)
- (inst b default-stack-vals))
-
- (emit-label regs-defaulted)
- (when (> nvals register-arg-count)
- (collect ((defaults))
- (do ((i register-arg-count (1+ i))
- (val (do ((i 0 (1+ i))
- (val values (tn-ref-across val)))
- ((= i register-arg-count) val))
- (tn-ref-across val)))
- ((null val))
-
- (let ((default-lab (gen-label))
- (tn (tn-ref-tn val)))
- (defaults (cons default-lab tn))
-
- (inst lwz move-temp ocfp-tn (* i n-word-bytes))
- (inst ble default-lab)
- (inst addic. temp temp (- (fixnumize 1)))
- (store-stack-tn tn move-temp)))
-
- (emit-label defaulting-done)
- (move csp-tn ocfp-tn)
-
- (let ((defaults (defaults)))
- (when defaults
- (assemble (*elsewhere*)
- (emit-label default-stack-vals)
- (trace-table-entry trace-table-fun-prologue)
- (do ((remaining defaults (cdr remaining)))
- ((null remaining))
- (let ((def (car remaining)))
- (emit-label (car def))
- (when (null (cdr remaining))
- (inst b defaulting-done))
- (store-stack-tn (cdr def) null-tn)))
- (trace-table-entry trace-table-normal))))))
-
- (inst compute-code-from-lra code-tn code-tn lra-label temp)))
+ (defaulting-done (gen-label))
+ (default-stack-vals (gen-label)))
+ ;; Branch off to the MV case.
+ (sb!assem:without-scheduling ()
+ (note-this-location vop :unknown-return)
+ (if (> nvals register-arg-count)
+ (inst addic. temp nargs-tn (- (fixnumize register-arg-count)))
+ (move csp-tn ocfp-tn))
+ (inst b regs-defaulted))
+
+ ;; Do the single value case.
+ (do ((i 1 (1+ i))
+ (val (tn-ref-across values) (tn-ref-across val)))
+ ((= i (min nvals register-arg-count)))
+ (move (tn-ref-tn val) null-tn))
+ (when (> nvals register-arg-count)
+ (move ocfp-tn csp-tn)
+ (inst b default-stack-vals))
+
+ (emit-label regs-defaulted)
+ (when (> nvals register-arg-count)
+ (collect ((defaults))
+ (do ((i register-arg-count (1+ i))
+ (val (do ((i 0 (1+ i))
+ (val values (tn-ref-across val)))
+ ((= i register-arg-count) val))
+ (tn-ref-across val)))
+ ((null val))
+
+ (let ((default-lab (gen-label))
+ (tn (tn-ref-tn val)))
+ (defaults (cons default-lab tn))
+
+ (inst lwz move-temp ocfp-tn (* i n-word-bytes))
+ (inst ble default-lab)
+ (inst addic. temp temp (- (fixnumize 1)))
+ (store-stack-tn tn move-temp)))
+
+ (emit-label defaulting-done)
+ (move csp-tn ocfp-tn)
+
+ (let ((defaults (defaults)))
+ (when defaults
+ (assemble (*elsewhere*)
+ (emit-label default-stack-vals)
+ (trace-table-entry trace-table-fun-prologue)
+ (do ((remaining defaults (cdr remaining)))
+ ((null remaining))
+ (let ((def (car remaining)))
+ (emit-label (car def))
+ (store-stack-tn (cdr def) null-tn)))
+ (inst b defaulting-done)
+ (trace-table-entry trace-table-normal))))))
+
+ (inst compute-code-from-lra code-tn code-tn lra-label temp)))
- ,@(unless (eq return :tail)
- '((lra-label (gen-label))))
- (filler
- (remove nil
- (list :load-nargs
- ,@(if (eq return :tail)
- '((unless (location= old-fp old-fp-pass)
- :load-old-fp)
- (unless (location= return-pc
- return-pc-pass)
- :load-return-pc)
- (when cur-nfp
- :frob-nfp))
- '(:comp-lra
- (when cur-nfp
- :frob-nfp)
- :save-fp
- :load-fp))))))
- (flet ((do-next-filler ()
- (let* ((next (pop filler))
- (what (if (consp next) (car next) next)))
- (ecase what
- (:load-nargs
- ,@(if variable
- `((inst sub nargs-pass csp-tn new-fp)
- ,@(let ((index -1))
- (mapcar #'(lambda (name)
- `(loadw ,name new-fp
- ,(incf index)))
- register-arg-names)))
- '((inst lr nargs-pass (fixnumize nargs)))))
- ,@(if (eq return :tail)
- '((:load-old-fp
- (sc-case old-fp
- (any-reg
- (inst mr old-fp-pass old-fp))
- (control-stack
- (loadw old-fp-pass cfp-tn
- (tn-offset old-fp)))))
- (:load-return-pc
- (sc-case return-pc
- (descriptor-reg
- (inst mr return-pc-pass return-pc))
- (control-stack
- (loadw return-pc-pass cfp-tn
- (tn-offset return-pc)))))
- (:frob-nfp
- (inst addi nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
- `((:comp-lra
- (inst compute-lra-from-code
- return-pc-pass code-tn lra-label temp))
- (:frob-nfp
- (store-stack-tn nfp-save cur-nfp))
- (:save-fp
- (inst mr old-fp-pass cfp-tn))
- (:load-fp
- ,(if variable
- '(move cfp-tn new-fp)
- '(if (> nargs register-arg-count)
- (move cfp-tn new-fp)
- (move cfp-tn csp-tn))))))
- ((nil))))))
- ,@(if named
- `((sc-case name
- (descriptor-reg (move name-pass name))
- (control-stack
- (loadw name-pass cfp-tn (tn-offset name))
- (do-next-filler))
- (constant
- (loadw name-pass code-tn (tn-offset name)
- other-pointer-lowtag)
- (do-next-filler)))
- (loadw entry-point name-pass fdefn-raw-addr-slot
- other-pointer-lowtag)
- (do-next-filler))
- `((sc-case arg-fun
- (descriptor-reg (move lexenv arg-fun))
- (control-stack
- (loadw lexenv cfp-tn (tn-offset arg-fun))
- (do-next-filler))
- (constant
- (loadw lexenv code-tn (tn-offset arg-fun)
- other-pointer-lowtag)
- (do-next-filler)))
- (loadw function lexenv closure-fun-slot
- fun-pointer-lowtag)
- (do-next-filler)
- (inst addi entry-point function
- (- (ash simple-fun-code-offset word-shift)
- fun-pointer-lowtag))
- ))
- (loop
- (if filler
- (do-next-filler)
- (return)))
-
- (note-this-location vop :call-site)
- (inst mtctr entry-point)
- ;; this following line is questionable. or else the alpha
- ;; code (which doesn't do it) is questionable
- ;; (inst mr code-tn function)
- (inst bctr))
-
- ,@(ecase return
- (:fixed
- '((emit-return-pc lra-label)
- (default-unknown-values vop values nvals move-temp
- temp lra-label)
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))))
- (:unknown
- '((emit-return-pc lra-label)
- (note-this-location vop :unknown-return)
- (receive-unknown-values values-start nvals start count
- lra-label temp)
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))))
- (:tail)))
+ ,@(unless (eq return :tail)
+ '((lra-label (gen-label))))
+ (filler
+ (remove nil
+ (list :load-nargs
+ ,@(if (eq return :tail)
+ '((unless (location= old-fp old-fp-pass)
+ :load-old-fp)
+ (unless (location= return-pc
+ return-pc-pass)
+ :load-return-pc)
+ (when cur-nfp
+ :frob-nfp))
+ '(:comp-lra
+ (when cur-nfp
+ :frob-nfp)
+ :save-fp
+ :load-fp))))))
+ (flet ((do-next-filler ()
+ (let* ((next (pop filler))
+ (what (if (consp next) (car next) next)))
+ (ecase what
+ (:load-nargs
+ ,@(if variable
+ `((inst sub nargs-pass csp-tn new-fp)
+ ,@(let ((index -1))
+ (mapcar #'(lambda (name)
+ `(loadw ,name new-fp
+ ,(incf index)))
+ register-arg-names)))
+ '((inst lr nargs-pass (fixnumize nargs)))))
+ ,@(if (eq return :tail)
+ '((:load-old-fp
+ (sc-case old-fp
+ (any-reg
+ (inst mr old-fp-pass old-fp))
+ (control-stack
+ (loadw old-fp-pass cfp-tn
+ (tn-offset old-fp)))))
+ (:load-return-pc
+ (sc-case return-pc
+ (descriptor-reg
+ (inst mr return-pc-pass return-pc))
+ (control-stack
+ (loadw return-pc-pass cfp-tn
+ (tn-offset return-pc)))))
+ (:frob-nfp
+ (inst addi nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
+ `((:comp-lra
+ (inst compute-lra-from-code
+ return-pc-pass code-tn lra-label temp))
+ (:frob-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (:save-fp
+ (inst mr old-fp-pass cfp-tn))
+ (:load-fp
+ ,(if variable
+ '(move cfp-tn new-fp)
+ '(if (> nargs register-arg-count)
+ (move cfp-tn new-fp)
+ (move cfp-tn csp-tn))))))
+ ((nil))))))
+ ,@(if named
+ `((sc-case name
+ (descriptor-reg (move name-pass name))
+ (control-stack
+ (loadw name-pass cfp-tn (tn-offset name))
+ (do-next-filler))
+ (constant
+ (loadw name-pass code-tn (tn-offset name)
+ other-pointer-lowtag)
+ (do-next-filler)))
+ (loadw entry-point name-pass fdefn-raw-addr-slot
+ other-pointer-lowtag)
+ (do-next-filler))
+ `((sc-case arg-fun
+ (descriptor-reg (move lexenv arg-fun))
+ (control-stack
+ (loadw lexenv cfp-tn (tn-offset arg-fun))
+ (do-next-filler))
+ (constant
+ (loadw lexenv code-tn (tn-offset arg-fun)
+ other-pointer-lowtag)
+ (do-next-filler)))
+ (loadw function lexenv closure-fun-slot
+ fun-pointer-lowtag)
+ (do-next-filler)
+ (inst addi entry-point function
+ (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag))
+ ))
+ (loop
+ (if filler
+ (do-next-filler)
+ (return)))
+
+ (note-this-location vop :call-site)
+ (inst mtctr entry-point)
+ ;; this following line is questionable. or else the alpha
+ ;; code (which doesn't do it) is questionable
+ ;; (inst mr code-tn function)
+ (inst bctr))
+
+ ,@(ecase return
+ (:fixed
+ '((emit-return-pc lra-label)
+ (default-unknown-values vop values nvals move-temp
+ temp lra-label)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))))
+ (:unknown
+ '((emit-return-pc lra-label)
+ (note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count
+ lra-label temp)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))))
+ (:tail)))
- ;; Clear the control stack, and restore the frame pointer.
- (move csp-tn cfp-tn)
- (move cfp-tn old-fp)
- ;; Out of here.
- (lisp-return return-pc lip :offset 2))
- (t
- ;; Establish the values pointer and values count.
- (move val-ptr cfp-tn)
- (inst lr nargs (fixnumize nvals))
- ;; restore the frame pointer and clear as much of the control
- ;; stack as possible.
- (move cfp-tn old-fp)
- (inst addi csp-tn val-ptr (* nvals n-word-bytes))
- ;; pre-default any argument register that need it.
- (when (< nvals register-arg-count)
- (dolist (reg (subseq (list a0 a1 a2 a3) nvals))
- (move reg null-tn)))
- ;; And away we go.
- (lisp-return return-pc lip)))
+ ;; Clear the control stack, and restore the frame pointer.
+ (move csp-tn cfp-tn)
+ (move cfp-tn old-fp)
+ ;; Out of here.
+ (lisp-return return-pc lip :offset 2))
+ (t
+ ;; Establish the values pointer and values count.
+ (move val-ptr cfp-tn)
+ (inst lr nargs (fixnumize nvals))
+ ;; restore the frame pointer and clear as much of the control
+ ;; stack as possible.
+ (move cfp-tn old-fp)
+ (inst addi csp-tn val-ptr (* nvals n-word-bytes))
+ ;; pre-default any argument register that need it.
+ (when (< nvals register-arg-count)
+ (dolist (reg (subseq (list a0 a1 a2 a3) nvals))
+ (move reg null-tn)))
+ ;; And away we go.
+ (lisp-return return-pc lip)))
- (assemble ()
- ;; Allocate a cons (2 words) for each item.
- (inst clrrwi result alloc-tn n-lowtag-bits)
- (inst ori result result list-pointer-lowtag)
- (move dst result)
- (inst slwi temp count 1)
- (inst add alloc-tn alloc-tn temp)
- (inst b enter)
-
- ;; Compute the next cons and store it in the current one.
- LOOP
- (inst addi dst dst (* 2 n-word-bytes))
- (storew dst dst -1 list-pointer-lowtag)
-
- ;; Grab one value.
- ENTER
- (loadw temp context)
- (inst addi context context n-word-bytes)
-
- ;; Dec count, and if != zero, go back for more.
- (inst addic. count count (- (fixnumize 1)))
- ;; Store the value into the car of the current cons (in the delay
- ;; slot).
- (storew temp dst 0 list-pointer-lowtag)
- (inst bgt loop)
-
-
- ;; NIL out the last cons.
- (storew null-tn dst 1 list-pointer-lowtag)))
- DONE))
-
-
-;;; Return the location and size of the more arg glob created by Copy-More-Arg.
-;;; Supplied is the total number of arguments supplied (originally passed in
-;;; NARGS.) Fixed is the number of non-rest arguments.
-;;;
-;;; We must duplicate some of the work done by Copy-More-Arg, since at that
-;;; time the environment is in a pretty brain-damaged state, preventing this
-;;; info from being returned as values. What we do is compute
-;;; supplied - fixed, and return a pointer that many words below the current
-;;; stack top.
+ (when dx-p
+ (align-csp temp))
+ ;; Allocate a cons (2 words) for each item.
+ (inst clrrwi result alloc-area-tn n-lowtag-bits)
+ (inst ori result result list-pointer-lowtag)
+ (move dst result)
+ (inst slwi temp count 1)
+ (inst add alloc-area-tn alloc-area-tn temp)
+ (inst b enter)
+
+ ;; Compute the next cons and store it in the current one.
+ (emit-label loop)
+ (inst addi dst dst (* 2 n-word-bytes))
+ (storew dst dst -1 list-pointer-lowtag)
+
+ ;; Grab one value.
+ (emit-label enter)
+ (loadw temp context)
+ (inst addi context context n-word-bytes)
+
+ ;; Dec count, and if != zero, go back for more.
+ (inst addic. count count (- (fixnumize 1)))
+ ;; Store the value into the car of the current cons (in the delay
+ ;; slot).
+ (storew temp dst 0 list-pointer-lowtag)
+ (inst bgt loop)
+
+ ;; NIL out the last cons.
+ (storew null-tn dst 1 list-pointer-lowtag))
+ (emit-label done))))
+
+
+;;; Return the location and size of the more arg glob created by
+;;; COPY-MORE-ARG. SUPPLIED is the total number of arguments supplied
+;;; (originally passed in NARGS.) Fixed is the number of non-rest
+;;; arguments.