X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Fcall.lisp;h=fd82448890b9fe3e69b35115a8288bddc7a37e65;hb=7c7e6276719b8d40fddec2070cad81064a25c8ed;hp=821483adcc94ba4e465afcfb4b186ec4fbcdc86e;hpb=29a9ccc860532b32c566aec095f570e999a9c52c;p=sbcl.git diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp index 821483a..fd82448 100644 --- a/src/compiler/alpha/call.lisp +++ b/src/compiler/alpha/call.lisp @@ -15,7 +15,7 @@ ;;; Return a wired TN describing the N'th full call argument passing ;;; location. -(!def-vm-support-routine standard-argument-location (n) +(!def-vm-support-routine standard-arg-location (n) (declare (type unsigned-byte n)) (if (< n register-arg-count) (make-wired-tn *backend-t-primitive-type* @@ -62,7 +62,7 @@ ;;; Make a TN for the standard argument count passing location. We ;;; only need to make the standard location, since a count is never ;;; passed when we are using non-standard conventions. -(!def-vm-support-routine make-argument-count-location () +(!def-vm-support-routine make-arg-count-location () (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset)) @@ -187,7 +187,7 @@ (inst lda csp-tn (* nargs n-word-bytes) csp-tn)))) ;;; Emit code needed at the return-point from an unknown-values call -;;; for a fixed number of values. Values is the head of the TN-Ref +;;; for a fixed number of values. Values is the head of the TN-REF ;;; list for the locations that the values are to be received into. ;;; Nvals is the number of values that are to be received (should ;;; equal the length of Values). @@ -306,7 +306,7 @@ default-value-8 (tn (tn-ref-tn val))) (defaults (cons default-lab tn)) - (inst blt temp default-lab) + (inst ble temp default-lab) (inst ldl move-temp (* i n-word-bytes) ocfp-tn) (inst subq temp (fixnumize 1) temp) (store-stack-tn tn move-temp))) @@ -315,16 +315,15 @@ default-value-8 (move ocfp-tn csp-tn) (let ((defaults (defaults))) - (assert defaults) + (aver defaults) (assemble (*elsewhere*) (emit-label default-stack-vals) (do ((remaining defaults (cdr remaining))) ((null remaining)) (let ((def (car remaining))) (emit-label (car def)) - (when (null (cdr remaining)) - (inst br zero-tn defaulting-done)) - (store-stack-tn (cdr def) null-tn))))))) + (store-stack-tn (cdr def) null-tn))) + (inst br zero-tn defaulting-done))))) (when lra-label (inst compute-code-from-lra code-tn code-tn lra-label temp)))) @@ -575,27 +574,27 @@ default-value-8 ;;; Named is true if the first argument is a symbol whose global ;;; function definition is to be called. ;;; -;;; Return is either :Fixed, :Unknown or :Tail: -;;; -- If :Fixed, then the call is for a fixed number of values, returned in -;;; the standard passing locations (passed as result operands). -;;; -- If :Unknown, then the result values are pushed on the stack, and the -;;; result values are specified by the Start and Count as in the +;;; Return is either :FIXED, :UNKNOWN or :TAIL: +;;; -- If :FIXED, then the call is for a fixed number of values, returned +;;; in the standard passing locations (passed as result operands). +;;; -- If :UNKNOWN, then the result values are pushed on the stack, and +;;; the result values are specified by the Start and Count as in the ;;; 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 Ocfp 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 +;;; cannot be specified with :TAIL return. TR variable argument call ;;; is implemented separately. ;;; ;;; In tail call with fixed arguments, the passing locations are ;;; passed as a more arg, but there is no new-FP, since the arguments ;;; have been set up in the current frame. (defmacro define-full-call (name named return variable) - (assert (not (and variable (eq return :tail)))) + (aver (not (and variable (eq return :tail)))) `(define-vop (,name ,@(when (eq return :unknown) '(unknown-values-receiver))) @@ -947,7 +946,12 @@ default-value-8 ;; restore the frame pointer and clear as much of the control ;; stack as possible. (move ocfp cfp-tn) - (inst addq val-ptr (* nvals n-word-bytes) csp-tn) + ;; ADDQ only accepts immediates of type (UNSIGNED-BYTE 8). Here, + ;; instead of adding (* NVALS N-WORD-BYTES), we use NARGS that + ;; we've carefully set up, but protect ourselves by averring that + ;; FIXNUMIZEation and multiplication by N-WORD-BYTES is the same. + (aver (= (* nvals n-word-bytes) (fixnumize nvals))) + (inst addq val-ptr nargs csp-tn) ;; pre-default any argument register that need it. (when (< nvals register-arg-count) (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) @@ -1102,6 +1106,9 @@ default-value-8 (define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg) ;;; Turn &MORE arg (context, count) into a list. +(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args)) + t) + (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) (count-arg :target count :scs (any-reg))) @@ -1112,10 +1119,13 @@ default-value-8 (:results (result :scs (descriptor-reg))) (:translate %listify-rest-args) (:policy :safe) + (:node-var node) (:generator 20 - (let ((enter (gen-label)) - (loop (gen-label)) - (done (gen-label))) + (let* ((enter (gen-label)) + (loop (gen-label)) + (done (gen-label)) + (dx-p (node-stack-allocate-p node)) + (alloc-area-tn (if dx-p csp-tn alloc-tn))) (move context-arg context) (move count-arg count) ;; Check to see if there are any arguments. @@ -1124,11 +1134,13 @@ default-value-8 ;; We need to do this atomically. (pseudo-atomic () + ;; align CSP + (when dx-p (align-csp temp)) ;; Allocate a cons (2 words) for each item. - (inst bis alloc-tn list-pointer-lowtag result) + (inst bis alloc-area-tn list-pointer-lowtag result) (move result dst) (inst sll count 1 temp) - (inst addq alloc-tn temp alloc-tn) + (inst addq alloc-area-tn temp alloc-area-tn) (inst br zero-tn enter) ;; Store the current cons in the cdr of the previous cons. @@ -1177,9 +1189,9 @@ default-value-8 (inst subq csp-tn count context))) ;;; Signal wrong argument count error if NARGS isn't equal to COUNT. -(define-vop (verify-argument-count) +(define-vop (verify-arg-count) (:policy :fast-safe) - (:translate sb!c::%verify-argument-count) + (:translate sb!c::%verify-arg-count) (:args (nargs :scs (any-reg))) (:arg-types positive-fixnum (:constant t)) (:temporary (:scs (any-reg) :type fixnum) temp) @@ -1188,7 +1200,7 @@ default-value-8 (:save-p :compute-only) (:generator 3 (let ((err-lab - (generate-error-code vop invalid-argument-count-error nargs))) + (generate-error-code vop invalid-arg-count-error nargs))) (cond ((zerop count) (inst bne nargs err-lab)) (t @@ -1208,14 +1220,14 @@ default-value-8 (:save-p :compute-only) (:generator 1000 (error-call vop ,error ,@args))))) - (frob argument-count-error invalid-argument-count-error - sb!c::%argument-count-error nargs) + (frob arg-count-error invalid-arg-count-error + sb!c::%arg-count-error nargs) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error object layout) - (frob odd-key-arguments-error odd-key-arguments-error - sb!c::%odd-key-arguments-error) - (frob unknown-key-argument-error unknown-key-argument-error - sb!c::%unknown-key-argument-error key) + (frob odd-key-args-error odd-key-args-error + sb!c::%odd-key-args-error) + (frob unknown-key-arg-error unknown-key-arg-error + sb!c::%unknown-key-arg-error key) (frob nil-fun-returned-error nil-fun-returned-error nil fun))