X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Fcall.lisp;h=79d4c7d8df889dde49e97b044b191297335316cf;hb=304c44d731bea3b9ce3c47d864d90eac92ba604e;hp=7998fc316623c06105d2566ee85ec0cc5eeee813;hpb=63fcb94b875a97e468d9add229e220ecceec2352;p=sbcl.git diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp index 7998fc3..79d4c7d 100644 --- a/src/compiler/alpha/call.lisp +++ b/src/compiler/alpha/call.lisp @@ -15,8 +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* @@ -30,22 +29,16 @@ ;;; is true, then use the standard (full call) location, otherwise use ;;; any legal location. Even in the non-standard case, this may be ;;; restricted by a desire to use a subroutine call instruction. -;;; (!def-vm-support-routine make-return-pc-passing-location (standard) - #!+gengc (declare (ignore standard)) - #!-gengc (if standard (make-wired-tn *backend-t-primitive-type* register-arg-scn lra-offset) - (make-restricted-tn *backend-t-primitive-type* register-arg-scn)) - #!+gengc - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ra-offset)) + (make-restricted-tn *backend-t-primitive-type* register-arg-scn))) -;;; This is similar to Make-Return-PC-Passing-Location, but makes a -;;; location to pass Old-FP in. This is (obviously) wired in the +;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a +;;; location to pass OLD-FP in. This is (obviously) wired in the ;;; standard convention, but is totally unrestricted in non-standard ;;; conventions, since we can always fetch it off of the stack using ;;; the arg pointer. -;;; (!def-vm-support-routine make-old-fp-passing-location (standard) (if standard (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset) @@ -56,22 +49,20 @@ ;;; debugger can find them at a known location. (!def-vm-support-routine make-old-fp-save-location (env) (specify-save-tn - (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) + (physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) (make-wired-tn *fixnum-primitive-type* control-stack-arg-scn ocfp-save-offset))) (!def-vm-support-routine make-return-pc-save-location (env) - (let ((ptype #!-gengc *backend-t-primitive-type* - #!+gengc *fixnum-primitive-type*)) + (let ((ptype *backend-t-primitive-type*)) (specify-save-tn - (environment-debug-live-tn (make-normal-tn ptype) env) - (make-wired-tn ptype control-stack-arg-scn - #!-gengc lra-save-offset #!+gengc ra-save-offset)))) + (physenv-debug-live-tn (make-normal-tn ptype) env) + (make-wired-tn ptype control-stack-arg-scn lra-save-offset)))) ;;; 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)) @@ -94,9 +85,9 @@ (make-normal-tn *fixnum-primitive-type*))) -;;; This function is called by the Entry-Analyze phase, allowing -;;; VM-dependent initialization of the IR2-Component structure. We -;;; push placeholder entries in the Constants to leave room for +;;; This function is called by the ENTRY-ANALYZE phase, allowing +;;; VM-dependent initialization of the IR2-COMPONENT structure. We +;;; push placeholder entries in the CONSTANTS to leave room for ;;; additional noise in the code object header. (!def-vm-support-routine select-component-format (component) (declare (type component component)) @@ -113,7 +104,7 @@ ;;; bytes on the PMAX. (defun bytes-needed-for-non-descriptor-stack-frame () (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1) - word-bytes)) + n-word-bytes)) ;;; This is used for setting up the Old-FP in local call. (define-vop (current-fp) @@ -140,12 +131,12 @@ (:generator 1 ;; Make sure the function is aligned, and drop a label pointing to ;; this function header. - (align lowtag-bits) - (trace-table-entry trace-table-function-prologue) + (align n-lowtag-bits) + (trace-table-entry trace-table-fun-prologue) (emit-label start-lab) ;; Allocate function header. - (inst function-header-word) - (dotimes (i (1- function-code-offset)) + (inst simple-fun-header-word) + (dotimes (i (1- simple-fun-code-offset)) (inst lword 0)) ;; The start of the actual code. ;; Compute CODE from the address of this entry point. @@ -156,7 +147,10 @@ ;; collector won't forget about us if we call anyone else. ) ;; Build our stack frames. - (inst lda csp-tn (* word-bytes (sb-allocated-size 'control-stack)) cfp-tn) + (inst lda + csp-tn + (* n-word-bytes (sb-allocated-size 'control-stack)) + cfp-tn) (let ((nfp (current-nfp-tn vop))) (when nfp (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame) @@ -169,17 +163,20 @@ (nfp :scs (any-reg))) (:info callee) (:generator 2 - (trace-table-entry trace-table-function-prologue) + (trace-table-entry trace-table-fun-prologue) (move csp-tn res) - (inst lda csp-tn (* word-bytes (sb-allocated-size 'control-stack)) csp-tn) - (when (ir2-environment-number-stack-p callee) + (inst lda + csp-tn + (* n-word-bytes (sb-allocated-size 'control-stack)) + csp-tn) + (when (ir2-physenv-number-stack-p callee) (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame) nsp-tn) (move nsp-tn nfp)) (trace-table-entry trace-table-normal))) ;;; Allocate a partial frame for passing stack arguments in a full -;;; call. Nargs is the number of arguments passed. If no stack +;;; 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) @@ -187,12 +184,10 @@ (:generator 2 (when (> nargs register-arg-count) (move csp-tn res) - (inst lda csp-tn (* nargs word-bytes) csp-tn)))) - + (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). @@ -271,8 +266,7 @@ default-value-8 (move ocfp-tn csp-tn) (inst nop)) (when lra-label - #!-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp) - #!+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp))) + (inst compute-code-from-lra code-tn code-tn lra-label temp))) (let ((regs-defaulted (gen-label)) (defaulting-done (gen-label)) (default-stack-vals (gen-label))) @@ -313,7 +307,7 @@ default-value-8 (defaults (cons default-lab tn)) (inst blt temp default-lab) - (inst ldl move-temp (* i word-bytes) ocfp-tn) + (inst ldl move-temp (* i n-word-bytes) ocfp-tn) (inst subq temp (fixnumize 1) temp) (store-stack-tn tn move-temp))) @@ -328,13 +322,11 @@ default-value-8 ((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 - #!-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp) - #!+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp)))) + (inst compute-code-from-lra code-tn code-tn lra-label temp)))) (values)) ;;;; unknown values receiving @@ -365,8 +357,7 @@ default-value-8 (inst nop)) (when lra-label - #!-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp) - #!+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp)) + (inst compute-code-from-lra code-tn code-tn lra-label temp)) (inst addq csp-tn 4 csp-tn) (storew (first *register-arg-tns*) csp-tn -1) (inst subq csp-tn 4 start) @@ -377,8 +368,7 @@ default-value-8 (assemble (*elsewhere*) (emit-label variable-values) (when lra-label - #!-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp) - #!+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp)) + (inst compute-code-from-lra code-tn code-tn lra-label temp)) (do ((arg *register-arg-tns* (rest arg)) (i 0 (1+ i))) ((null arg)) @@ -513,7 +503,7 @@ default-value-8 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:temporary (:scs (non-descriptor-reg)) temp) (:generator 5 - (let (#!-gengc (label (gen-label)) + (let ((label (gen-label)) (cur-nfp (current-nfp-tn vop))) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) @@ -542,16 +532,15 @@ default-value-8 (return-pc :target return-pc-temp) (vals :more t)) (:temporary (:sc any-reg :from (:argument 0)) ocfp-temp) - (:temporary (:sc #!-gengc descriptor-reg #!+gengc any-reg - :from (:argument 1)) + (:temporary (:sc any-reg :from (:argument 1)) return-pc-temp) - #!-gengc (:temporary (:scs (interior-reg)) lip) + (:temporary (:scs (interior-reg)) lip) (:move-args :known-return) (:info val-locs) (:ignore val-locs vals) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-function-epilogue) + (trace-table-entry trace-table-fun-epilogue) (maybe-load-stack-tn ocfp-temp ocfp) (maybe-load-stack-tn return-pc-temp return-pc) (move cfp-tn csp-tn) @@ -559,13 +548,12 @@ default-value-8 (when cur-nfp (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) nsp-tn))) - (inst subq return-pc-temp (- other-pointer-type word-bytes) lip) + (inst subq return-pc-temp (- other-pointer-lowtag n-word-bytes) lip) (move ocfp-temp cfp-tn) (inst ret zero-tn lip 1) (trace-table-entry trace-table-normal))) - -;;;; Full call: +;;;; full call: ;;;; ;;;; There is something of a cross-product effect with full calls. ;;;; Different versions are used depending on whether we know the @@ -586,20 +574,20 @@ 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 @@ -672,11 +660,11 @@ default-value-8 nargs-pass) ,@(when variable - (mapcar #'(lambda (name offset) - `(:temporary (:sc descriptor-reg - :offset ,offset - :to :eval) - ,name)) + (mapcar (lambda (name offset) + `(:temporary (:sc descriptor-reg + :offset ,offset + :to :eval) + ,name)) register-arg-names *register-arg-offsets*)) ,@(when (eq return :fixed) '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) @@ -720,11 +708,11 @@ default-value-8 ,@(if variable `((inst subq csp-tn new-fp nargs-pass) ,@(let ((index -1)) - (mapcar #'(lambda (name) - `(inst ldl ,name - ,(ash (incf index) - word-shift) - new-fp)) + (mapcar (lambda (name) + `(inst ldl ,name + ,(ash (incf index) + word-shift) + new-fp)) register-arg-names))) '((inst li (fixnumize nargs) nargs-pass)))) ,@(if (eq return :tail) @@ -777,11 +765,11 @@ default-value-8 (constant (inst ldl name-pass (- (ash (tn-offset name) word-shift) - other-pointer-type) code-tn) + other-pointer-lowtag) code-tn) (do-next-filler))) (inst ldl entry-point (- (ash fdefn-raw-addr-slot word-shift) - other-pointer-type) name-pass) + other-pointer-lowtag) name-pass) (do-next-filler)) `((sc-case arg-fun (descriptor-reg (move arg-fun lexenv)) @@ -792,22 +780,22 @@ default-value-8 (constant (inst ldl lexenv (- (ash (tn-offset arg-fun) word-shift) - other-pointer-type) code-tn) + other-pointer-lowtag) code-tn) (do-next-filler))) #!-gengc (inst ldl function - (- (ash closure-function-slot word-shift) - function-pointer-type) lexenv) + (- (ash closure-fun-slot word-shift) + fun-pointer-lowtag) lexenv) #!-gengc (do-next-filler) #!-gengc (inst addq function - (- (ash function-code-offset word-shift) - function-pointer-type) entry-point) + (- (ash simple-fun-code-offset word-shift) + fun-pointer-lowtag) entry-point) #!+gengc (inst ldl entry-point (- (ash closure-entry-point-slot word-shift) - function-pointer-type) lexenv) + fun-pointer-lowtag) lexenv) #!+gengc (do-next-filler))) (loop @@ -896,7 +884,7 @@ default-value-8 (:vop-var vop) (:generator 6 ;; Clear the number stack. - (trace-table-entry trace-table-function-epilogue) + (trace-table-entry trace-table-fun-epilogue) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) @@ -908,7 +896,7 @@ default-value-8 #!-gengc (lisp-return return-pc lip :offset 2) #!+gengc (progn - (inst addq return-pc (* 2 word-bytes) temp) + (inst addq return-pc (* 2 n-word-bytes) temp) (unless (location= ra return-pc) (inst move ra return-pc)) (inst ret zero-tn temp 1)) @@ -947,7 +935,7 @@ default-value-8 (:vop-var vop) (:generator 6 ;; Clear the number stack. - (trace-table-entry trace-table-function-epilogue) + (trace-table-entry trace-table-fun-epilogue) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) @@ -958,7 +946,7 @@ 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 word-bytes) csp-tn) + (inst addq val-ptr (* nvals n-word-bytes) 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)) @@ -994,7 +982,7 @@ default-value-8 (:vop-var vop) (:generator 13 - (trace-table-entry trace-table-function-epilogue) + (trace-table-entry trace-table-fun-epilogue) (let ((not-single (gen-label))) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) @@ -1046,7 +1034,7 @@ default-value-8 (move lexenv closure))) ;;; Copy a &MORE arg from the argument area to the end of the current -;;; frame. FIXED is the number of non-more arguments. +;;; frame. FIXED is the number of non-&MORE arguments. (define-vop (copy-more-arg) (:temporary (:sc any-reg :offset nl0-offset) result) (:temporary (:sc any-reg :offset nl1-offset) count) @@ -1059,8 +1047,9 @@ default-value-8 (do-regs (gen-label)) (done (gen-label))) (when (< fixed register-arg-count) - ;; Save a pointer to the results so we can fill in register args. - ;; We don't need this if there are more fixed args than reg args. + ;; Save a pointer to the results so we can fill in register + ;; args. We don't need this if there are more fixed args than + ;; reg args. (move csp-tn result)) ;; Allocate the space on the stack. (cond ((zerop fixed) @@ -1071,30 +1060,30 @@ default-value-8 (inst ble count done) (inst addq csp-tn count csp-tn))) (when (< fixed register-arg-count) - ;; We must stop when we run out of stack args, not when we run out of - ;; more args. + ;; We must stop when we run out of stack args, not when we run + ;; out of &MORE args. (inst subq nargs-tn (fixnumize register-arg-count) count)) ;; Initialize dst to be end of stack. (move csp-tn dst) ;; Everything of interest in registers. (inst ble count do-regs) - ;; Initialize src to be end of args. + ;; Initialize SRC to be end of args. (inst addq cfp-tn nargs-tn src) (emit-label loop) ;; *--dst = *--src, --count - (inst subq src word-bytes src) + (inst subq src n-word-bytes src) (inst subq count (fixnumize 1) count) (loadw temp src) - (inst subq dst word-bytes dst) + (inst subq dst n-word-bytes dst) (storew temp dst) (inst bgt count loop) (emit-label do-regs) (when (< fixed register-arg-count) - ;; Now we have to deposit any more args that showed up in registers. - ;; We know there is at least one more arg, otherwise we would have - ;; branched to done up at the top. + ;; Now we have to deposit any more args that showed up in + ;; registers. We know there is at least one &MORE arg, + ;; otherwise we would have branched to DONE up at the top. (inst subq nargs-tn (fixnumize (1+ fixed)) count) (do ((i fixed (1+ i))) ((>= i register-arg-count)) @@ -1106,7 +1095,7 @@ default-value-8 (inst subq count (fixnumize 1) count))) (emit-label done)))) -;;; &More args are stored consecutively on the stack, starting +;;; &MORE args are stored consecutively on the stack, starting ;;; immediately at the context pointer. The context pointer is not ;;; typed, so the lowtag is 0. (define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg) @@ -1115,7 +1104,9 @@ default-value-8 (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) (count-arg :target count :scs (any-reg))) - (:arg-types * tagged-num) + (:info dx) + (:ignore dx) + (:arg-types * tagged-num (:constant t)) (:temporary (:scs (any-reg) :from (:argument 0)) context) (:temporary (:scs (any-reg) :from (:argument 1)) count) (:temporary (:scs (descriptor-reg) :from :eval) temp dst) @@ -1135,7 +1126,7 @@ default-value-8 ;; We need to do this atomically. (pseudo-atomic () ;; Allocate a cons (2 words) for each item. - (inst bis alloc-tn list-pointer-type result) + (inst bis alloc-tn list-pointer-lowtag result) (move result dst) (inst sll count 1 temp) (inst addq alloc-tn temp alloc-tn) @@ -1143,31 +1134,31 @@ default-value-8 ;; Store the current cons in the cdr of the previous cons. (emit-label loop) - (inst addq dst (* 2 word-bytes) dst) - (storew dst dst -1 list-pointer-type) + (inst addq dst (* 2 n-word-bytes) dst) + (storew dst dst -1 list-pointer-lowtag) (emit-label enter) ;; Grab one value. (loadw temp context) - (inst addq context word-bytes context) + (inst addq context n-word-bytes context) ;; Store the value in the car (in delay slot) - (storew temp dst 0 list-pointer-type) + (storew temp dst 0 list-pointer-lowtag) - ;; Dec count, and if != zero, go back for more. + ;; Decrement count, and if != zero, go back for more. (inst subq count (fixnumize 1) count) (inst bne count loop) ;; NIL out the last cons. - (storew null-tn dst 1 list-pointer-type)) + (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 +;;; 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 +;;; 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 @@ -1186,11 +1177,10 @@ default-value-8 (inst subq supplied (fixnumize fixed) count) (inst subq csp-tn count context))) - -;;; Signal wrong argument count error if Nargs isn't equal to Count. -(define-vop (verify-argument-count) +;;; Signal wrong argument count error if NARGS isn't equal to 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) @@ -1199,7 +1189,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 @@ -1212,21 +1202,21 @@ default-value-8 ,@(when translate `((:policy :fast-safe) (:translate ,translate))) - (:args ,@(mapcar #'(lambda (arg) - `(,arg :scs (any-reg descriptor-reg))) + (:args ,@(mapcar (lambda (arg) + `(,arg :scs (any-reg descriptor-reg))) args)) (:vop-var vop) (: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 nil-function-returned-error nil-function-returned-error nil fun)) + (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))