From d65b9573423610589319889a0eeb31c5501862bf Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Fri, 15 Sep 2017 14:24:21 +0300 Subject: [PATCH] Remove define-static-fun on MIPS. --- src/compiler/mips/arith.lisp | 24 -------- src/compiler/mips/call.lisp | 128 ++++++++++++++++++++------------------ src/compiler/mips/static-fn.lisp | 129 +-------------------------------------- src/compiler/mips/subprim.lisp | 3 - 4 files changed, 73 insertions(+), 211 deletions(-) rewrite src/compiler/mips/static-fn.lisp (99%) diff --git a/src/compiler/mips/arith.lisp b/src/compiler/mips/arith.lisp index 0e4197899..dbb22e948 100644 --- a/src/compiler/mips/arith.lisp +++ b/src/compiler/mips/arith.lisp @@ -888,27 +888,3 @@ (:translate sb!bignum:%ashl) (:generator 1 (inst sll result digit count))) - - -;;;; Static functions. - -(define-static-fun two-arg-gcd (x y) :translate gcd) -(define-static-fun two-arg-lcm (x y) :translate lcm) - -(define-static-fun two-arg-+ (x y) :translate +) -(define-static-fun two-arg-- (x y) :translate -) -(define-static-fun two-arg-* (x y) :translate *) -(define-static-fun two-arg-/ (x y) :translate /) - -(define-static-fun two-arg-< (x y) :translate <) -(define-static-fun two-arg-<= (x y) :translate <=) -(define-static-fun two-arg-> (x y) :translate >) -(define-static-fun two-arg->= (x y) :translate >=) -(define-static-fun two-arg-= (x y) :translate =) -(define-static-fun two-arg-/= (x y) :translate /=) - -(define-static-fun %negate (x) :translate %negate) - -(define-static-fun two-arg-and (x y) :translate logand) -(define-static-fun two-arg-ior (x y) :translate logior) -(define-static-fun two-arg-xor (x y) :translate logxor) diff --git a/src/compiler/mips/call.lisp b/src/compiler/mips/call.lisp index a1c974125..ce5001d66 100644 --- a/src/compiler/mips/call.lisp +++ b/src/compiler/mips/call.lisp @@ -603,10 +603,13 @@ default-value-8 (:args ,@(unless (eq return :tail) '((new-fp :scs (any-reg) :to :eval))) + ,@(case named + ((nil) + '((arg-fun :target lexenv))) + (:direct) + (t + '((name :target name-pass)))) - ,(if named - '(name :target name-pass) - '(arg-fun :target lexenv)) ,@(when (eq return :tail) '((ocfp :target ocfp-pass) @@ -625,6 +628,7 @@ default-value-8 (:vop-var vop) (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) ,@(unless variable '(nargs)) + ,@(when (eq named :direct) '(fun)) ,@(when (eq return :fixed) '(nvals)) step-instrumenting) @@ -644,18 +648,19 @@ default-value-8 :to :eval) return-pc-pass) - ,@(if named - `((:temporary (:sc descriptor-reg :offset fdefn-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - name-pass)) - - `((:temporary (:sc descriptor-reg :offset lexenv-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - lexenv) - (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval) - function))) + ,@(case named + ((t) + `((:temporary (:sc descriptor-reg :offset fdefn-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + name-pass))) + ((nil) + `((:temporary (:sc descriptor-reg :offset lexenv-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + lexenv) + (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval) + function)))) (:temporary (:sc any-reg :offset nargs-offset :to :eval) nargs-pass) @@ -769,49 +774,53 @@ default-value-8 (ash (reg-tn-encoding callable-tn) 5))) (emit-label step-done-label)))) - - ,@(if named - `((sc-case name - (descriptor-reg (move name-pass name)) - (control-stack - (inst lw name-pass cfp-tn - (ash (tn-offset name) word-shift)) - (do-next-filler)) - (constant - (inst lw name-pass code-tn - (- (ash (tn-offset name) word-shift) - other-pointer-lowtag)) - (do-next-filler))) - ;; The step instrumenting must be done after - ;; FUNCTION is loaded, but before ENTRY-POINT is - ;; calculated. - (insert-step-instrumenting name-pass) - (inst lw entry-point name-pass - (- (ash fdefn-raw-addr-slot word-shift) - other-pointer-lowtag)) - (do-next-filler)) - `((sc-case arg-fun - (descriptor-reg (move lexenv arg-fun)) - (control-stack - (inst lw lexenv cfp-tn - (ash (tn-offset arg-fun) word-shift)) - (do-next-filler)) - (constant - (inst lw lexenv code-tn - (- (ash (tn-offset arg-fun) word-shift) - other-pointer-lowtag)) - (do-next-filler))) - (inst lw function lexenv - (- (ash closure-fun-slot word-shift) - fun-pointer-lowtag)) - (do-next-filler) - ;; The step instrumenting must be done before - ;; after FUNCTION is loaded, but before ENTRY-POINT - ;; is calculated. - (insert-step-instrumenting function) - (inst addu entry-point function - (- (ash simple-fun-code-offset word-shift) - fun-pointer-lowtag)))) + (declare (ignorable #'insert-step-instrumenting)) + ,@(case named + ((t) + `((sc-case name + (descriptor-reg (move name-pass name)) + (control-stack + (inst lw name-pass cfp-tn + (ash (tn-offset name) word-shift)) + (do-next-filler)) + (constant + (inst lw name-pass code-tn + (- (ash (tn-offset name) word-shift) + other-pointer-lowtag)) + (do-next-filler))) + ;; The step instrumenting must be done after + ;; FUNCTION is loaded, but before ENTRY-POINT is + ;; calculated. + (insert-step-instrumenting name-pass) + (inst lw entry-point name-pass + (- (ash fdefn-raw-addr-slot word-shift) + other-pointer-lowtag)) + (do-next-filler))) + ((nil) + `((sc-case arg-fun + (descriptor-reg (move lexenv arg-fun)) + (control-stack + (inst lw lexenv cfp-tn + (ash (tn-offset arg-fun) word-shift)) + (do-next-filler)) + (constant + (inst lw lexenv code-tn + (- (ash (tn-offset arg-fun) word-shift) + other-pointer-lowtag)) + (do-next-filler))) + (inst lw function lexenv + (- (ash closure-fun-slot word-shift) + fun-pointer-lowtag)) + (do-next-filler) + ;; The step instrumenting must be done before + ;; after FUNCTION is loaded, but before ENTRY-POINT + ;; is calculated. + (insert-step-instrumenting function) + (inst addu entry-point function + (- (ash simple-fun-code-offset word-shift) + fun-pointer-lowtag)))) + (:direct + `((inst lw entry-point null-tn (static-fun-offset fun))))) (loop (if (cdr filler) (do-next-filler) @@ -841,10 +850,13 @@ default-value-8 (define-full-call call nil :fixed nil) (define-full-call call-named t :fixed nil) +(define-full-call static-call-named :direct :fixed nil) (define-full-call multiple-call nil :unknown nil) (define-full-call multiple-call-named t :unknown nil) +(define-full-call static-multiple-call-named :direct :unknown nil) (define-full-call tail-call nil :tail nil) (define-full-call tail-call-named t :tail nil) +(define-full-call static-tail-call-named :direct :tail nil) (define-full-call call-variable nil :fixed t) (define-full-call multiple-call-variable nil :unknown t) diff --git a/src/compiler/mips/static-fn.lisp b/src/compiler/mips/static-fn.lisp dissimilarity index 99% index 6f9cdd941..6c8e1b6a5 100644 --- a/src/compiler/mips/static-fn.lisp +++ b/src/compiler/mips/static-fn.lisp @@ -1,126 +1,3 @@ -(in-package "SB!VM") - - - -(define-vop (static-fun-template) - (:save-p t) - (:policy :safe) - (:variant-vars symbol) - (:vop-var vop) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg)) move-temp) - (:temporary (:sc descriptor-reg :offset lra-offset) lra) - (:temporary (:sc interior-reg) entry-point) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset ocfp-offset) ocfp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)) - - -(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) - -(defun static-fun-template-name (num-args num-results) - (intern (format nil "~:@(~R-arg-~R-result-static-fun~)" - num-args num-results))) - -(defun moves (dst src) - (collect ((moves)) - (do ((dst dst (cdr dst)) - (src src (cdr src))) - ((or (null dst) (null src))) - (moves `(move ,(car dst) ,(car src)))) - (moves))) - -(defun static-fun-template-vop (num-args num-results) - (unless (and (<= num-args register-arg-count) - (<= num-results register-arg-count)) - (error "either too many args (~W) or too many results (~W); max = ~W" - num-args num-results register-arg-count)) - (let ((num-temps (max num-args num-results))) - (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) - (dotimes (i num-results) - (let ((result-name (intern (format nil "RESULT-~D" i)))) - (result-names result-name) - (results `(,result-name :scs (any-reg descriptor-reg))))) - (dotimes (i num-temps) - (let ((temp-name (intern (format nil "TEMP-~D" i)))) - (temp-names temp-name) - (temps `(:temporary (:sc descriptor-reg - :offset ,(nth i *register-arg-offsets*) - ,@(when (< i num-args) - `(:from (:argument ,i))) - ,@(when (< i num-results) - `(:to (:result ,i) - :target ,(nth i (result-names))))) - ,temp-name)))) - (dotimes (i num-args) - (let ((arg-name (intern (format nil "ARG-~D" i)))) - (arg-names arg-name) - (args `(,arg-name - :scs (any-reg descriptor-reg null zero) - :target ,(nth i (temp-names)))))) - `(define-vop (,(static-fun-template-name num-args num-results) - static-fun-template) - (:args ,@(args)) - ,@(temps) - (:results ,@(results)) - (:generator ,(+ 50 num-args num-results) - (let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - ,@(moves (temp-names) (arg-names)) - (inst li nargs (fixnumize ,num-args)) - (inst lw entry-point null-tn (static-fun-offset symbol)) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (move ocfp cfp-tn) - (inst compute-lra-from-code lra code-tn lra-label temp) - (note-this-location vop :call-site) - (inst j entry-point) - (move cfp-tn csp-tn t) - (emit-return-pc lra-label) - ,(collect ((bindings) (links)) - (do ((temp (temp-names) (cdr temp)) - (name 'values (gensym)) - (prev nil name) - (i 0 (1+ i))) - ((= i num-results)) - (bindings `(,name - (make-tn-ref ,(car temp) nil))) - (when prev - (links `(setf (tn-ref-across ,prev) ,name)))) - `(let ,(bindings) - ,@(links) - (default-unknown-values vop - ,(if (zerop num-results) nil 'values) - ,num-results move-temp temp lra-label))) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)) - ,@(moves (result-names) (temp-names)))))))) - - -) ; EVAL-WHEN - - -(expand - (collect ((templates (list 'progn))) - (dotimes (i register-arg-count) - (templates (static-fun-template-vop i 1))) - (templates))) - - -(defmacro define-static-fun (name args &key (results '(x)) translate - policy cost arg-types result-types) - `(define-vop (,name - ,(static-fun-template-name (length args) - (length results))) - (:variant ',name) - (:note ,(format nil "static-fun ~@(~S~)" name)) - ,@(when translate - `((:translate ,translate))) - ,@(when policy - `((:policy ,policy))) - ,@(when cost - `((:generator-cost ,cost))) - ,@(when arg-types - `((:arg-types ,@arg-types))) - ,@(when result-types - `((:result-types ,@result-types))))) +(in-package "SB!VM") + +;;; Do nothing, it's all done by STATIC-CALL-NAMED and STATIC-TAIL-CALL-NAMED diff --git a/src/compiler/mips/subprim.lisp b/src/compiler/mips/subprim.lisp index 11a4cb273..828b9a5d2 100644 --- a/src/compiler/mips/subprim.lisp +++ b/src/compiler/mips/subprim.lisp @@ -40,6 +40,3 @@ (emit-label done) (move result count)))) - - -(define-static-fun length (object) :translate length) -- 2.11.4.GIT