X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fstatic-fn.lisp;h=ec4809a1e46b2e58a8febbba8ed57e936552accd;hb=23e8ed407c99d1b26465acc0aa61c1c88cc81893;hp=1842dffade64b3a427517b883086b142fad329db;hpb=4ebdc81b1a9c6dbed6e98b112afc8dd32b17a2dd;p=sbcl.git diff --git a/src/compiler/x86-64/static-fn.lisp b/src/compiler/x86-64/static-fn.lisp index 1842dff..ec4809a 100644 --- a/src/compiler/x86-64/static-fn.lisp +++ b/src/compiler/x86-64/static-fn.lisp @@ -16,145 +16,141 @@ (:policy :safe) (:variant-vars function) (:vop-var vop) - (:node-var node) - (:temporary (:sc unsigned-reg :offset ebx-offset - :from (:eval 0) :to (:eval 2)) ebx) (:temporary (:sc unsigned-reg :offset ecx-offset - :from (:eval 0) :to (:eval 2)) ecx)) + :from (:eval 0) :to (:eval 2)) ecx)) (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))) + num-args num-results))) (defun moves (dst src) (collect ((moves)) (do ((dst dst (cdr dst)) - (src src (cdr src))) - ((or (null dst) (null src))) + (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)) + (<= 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))) + num-args num-results register-arg-count)) + (let ((num-temps (max num-args num-results)) + (node (sb!xc:gensym "NODE-")) + (new-rbp-ea + '(make-ea :qword + :disp (frame-byte-offset (+ sp->fp-offset -3 ocfp-save-offset)) + :base rsp-tn))) (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))))) + (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*) - :from ,(if (< i num-args) - `(:argument ,i) - '(:eval 1)) - :to ,(if (< i num-results) - `(:result ,i) - '(:eval 1)) - ,@(when (< i num-results) - `(:target ,(nth i (result-names))))) - ,temp-name)))) + (let ((temp-name (intern (format nil "TEMP-~D" i)))) + (temp-names temp-name) + (temps `(:temporary (:sc descriptor-reg + :offset ,(nth i *register-arg-offsets*) + :from ,(if (< i num-args) + `(:argument ,i) + '(:eval 1)) + :to ,(if (< i num-results) + `(:result ,i) + '(:eval 1)) + ,@(when (< i num-results) + `(: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) - :target ,(nth i (temp-names)))))) + (let ((arg-name (intern (format nil "ARG-~D" i)))) + (arg-names arg-name) + (args `(,arg-name + :scs (any-reg descriptor-reg) + :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) - ,@(moves (temp-names) (arg-names)) + static-fun-template) + (:args ,@(args)) + ,@(temps) + (:results ,@(results)) + (:node-var ,node) + (:generator ,(+ 50 num-args num-results) + ,@(moves (temp-names) (arg-names)) - ;; If speed not more important than size, duplicate the - ;; effect of the ENTER with discrete instructions. Takes - ;; 2+1+3+2=8 bytes as opposed to 4+3=7 bytes. - (cond ((policy node (>= speed space)) - (inst mov ebx rsp-tn) - ;; Save the old-fp - (inst push rbp-tn) - ;; Ensure that at least three slots are available; one - ;; above, two more needed. - (inst sub rsp-tn (fixnumize 2)) - (inst mov rbp-tn ebx)) - (t - (inst enter (fixnumize 2)) - ;; The enter instruction pushes EBP and then copies - ;; ESP into EBP. We want the new EBP to be the - ;; original ESP, so we fix it up afterwards. - (inst add rbp-tn (fixnumize 1)))) + ;; If speed is at least as important as size, duplicate the + ;; effect of the ENTER with discrete instructions. Takes + ;; 3+4+4=11 bytes as opposed to 1+4=5 bytes. + (cond ((policy ,node (>= speed space)) + (inst sub rsp-tn (* 3 n-word-bytes)) + (inst mov ,new-rbp-ea rbp-tn) + (inst lea rbp-tn ,new-rbp-ea)) + (t + ;; Dummy for return address. + (inst push rbp-tn) + (inst enter n-word-bytes))) - ,(if (zerop num-args) - '(inst xor ecx ecx) - `(inst mov ecx (fixnumize ,num-args))) + ,(if (zerop num-args) + '(inst xor ecx ecx) + `(inst mov ecx ,(fixnumize num-args))) - (note-this-location vop :call-site) - ;; Old CMU CL comment: - ;; STATIC-FUN-OFFSET gives the offset from the start of - ;; the NIL object to the static function FDEFN and has the - ;; low tag of 1 added. When the NIL symbol value with its - ;; low tag of 3 is added the resulting value points to the - ;; raw address slot of the fdefn (at +4). - ;; FIXME: Since the fork from CMU CL, we've swapped - ;; FUN-POINTER-LOWTAG and INSTANCE-POINTER-LOWTAG, so the - ;; text above is no longer right. Mysteriously, things still - ;; work. It would be good to explain why. (Is this code no - ;; longer executed? Does it not depend on the - ;; 1+3=4=fdefn_raw_address_offset relationship above? - ;; Is something else going on?) - (inst call (make-ea :qword - :disp (+ nil-value - (static-fun-offset function)))) - ,(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))) - ,@(moves (result-names) (temp-names))))))) + (note-this-location vop :call-site) + ;; Old CMU CL comment: + ;; STATIC-FUN-OFFSET gives the offset from the start of + ;; the NIL object to the static function FDEFN and has the + ;; low tag of 1 added. When the NIL symbol value with its + ;; low tag of 3 is added the resulting value points to the + ;; raw address slot of the fdefn (at +4). + ;; FIXME: Since the fork from CMU CL, we've swapped + ;; FUN-POINTER-LOWTAG and INSTANCE-POINTER-LOWTAG, so the + ;; text above is no longer right. Mysteriously, things still + ;; work. It would be good to explain why. (Is this code no + ;; longer executed? Does it not depend on the + ;; 1+3=4=fdefn_raw_address_offset relationship above? + ;; Is something else going on?) + (call-indirect (+ nil-value (static-fun-offset function))) + ,(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 + ,node))) + ,@(moves (result-names) (temp-names))))))) ) ; EVAL-WHEN (macrolet ((frob (num-args num-res) - (static-fun-template-vop (eval num-args) (eval num-res)))) + (static-fun-template-vop (eval num-args) (eval num-res)))) (frob 0 1) (frob 1 1) (frob 2 1) (frob 3 1)) (defmacro define-static-fun (name args &key (results '(x)) translate - policy cost arg-types result-types) + policy cost arg-types result-types) `(define-vop (,name - ,(static-fun-template-name (length args) - (length results))) + ,(static-fun-template-name (length args) + (length results))) (:variant ',name) (:note ,(format nil "static-fun ~@(~S~)" name)) ,@(when translate - `((:translate ,translate))) + `((:translate ,translate))) ,@(when policy - `((:policy ,policy))) + `((:policy ,policy))) ,@(when cost - `((:generator-cost ,cost))) + `((:generator-cost ,cost))) ,@(when arg-types - `((:arg-types ,@arg-types))) + `((:arg-types ,@arg-types))) ,@(when result-types - `((:result-types ,@result-types))))) + `((:result-types ,@result-types)))))