From 41520f928e32f32e7d99732fd3daac8426c7f5cd Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Tue, 29 Jun 2021 00:00:10 -0400 Subject: [PATCH] Fix list* vop --- src/assembly/x86-64/tramps.lisp | 13 ++++++ src/compiler/generic/objdef.lisp | 15 ++++--- src/compiler/ir2tran.lisp | 14 +++++-- src/compiler/x86-64/alloc.lisp | 69 ++++++++++++++++++-------------- 4 files changed, 73 insertions(+), 38 deletions(-) diff --git a/src/assembly/x86-64/tramps.lisp b/src/assembly/x86-64/tramps.lisp index e3cefcae0..d5acfaca3 100644 --- a/src/assembly/x86-64/tramps.lisp +++ b/src/assembly/x86-64/tramps.lisp @@ -33,6 +33,19 @@ (inst mov r11-tn rax-tn)) (inst ret 8)) ; pop argument +(define-assembly-routine (list*) () + (with-registers-preserved (c xmm) + (inst mov rdi-tn (ea 16 rbp-tn)) ; 1st C call arg + (inst call (make-fixup "alloc_list" :foreign)) + (inst mov (ea 16 rbp-tn) rax-tn))) ; result + +#+avx2 +(define-assembly-routine (list*.ymmsave) () + (with-registers-preserved (c ymm) + (inst mov rdi-tn (ea 16 rbp-tn)) ; 1st C call arg + (inst call (make-fixup "alloc_list" :foreign)) + (inst mov (ea 16 rbp-tn) rax-tn))) ; result + (define-assembly-routine (make-list (:return-style :none)) () (with-registers-preserved (c xmm) (inst mov rdi-tn (ea 16 rbp-tn)) ; 1st C call arg diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 051b388bd..966eea1d8 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -511,15 +511,18 @@ during backtrace. (alien-stack-pointer :c-type "lispobj *" :pointer t :special *alien-stack-pointer*) (stepping) + ;; Deterministic consing profile recording area. + (profile-data :c-type "uword_t *" :pointer t) + ;; Lisp needs only the first two fields of 'struct alloc_region', + ;; so it's OK if the final 2 fields of the second region have offsets >= 128 + ;; from the base of the thread structure. + #+gencgc (alloc-region :c-type "struct alloc_region" :length 4) + #+gencgc (cons-region :c-type "struct alloc_region" :length 4) + ;; END of slots to keep near the beginning. + (dynspace-addr) (dynspace-card-count) (dynspace-pte-base) - ;; Deterministic consing profile recording area. - (profile-data :c-type "uword_t *" :pointer t) - ;; Lisp needs only the first two fields of the alloc_region, so it's OK if the - ;; final 2 fields have offsets >= 128 from the base of the thread structure. - #+gencgc (alloc-region :c-type "struct alloc_region" :length 4) - ;; END of slots to keep near the beginning. ;; This is the original address at which the memory was allocated, ;; which may have different alignment then what we prefer to use. diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index bac98c826..814e213e9 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -2060,9 +2060,14 @@ not stack-allocated LVAR ~S." source-lvar))))) ;; than moving every argument into a passing location. (ir2-convert-full-call node block)) (t - (let* ((scs (operand-parse-scs + ;; CONS is not the most mnemonic name for allocating 2 cons cells, + ;; but I don't want to complicate this more than necessary. + ;; Just remember that LIST* is the more general vop. + (let* ((vopname #+x86-64 (if (<= n-cons-cells 2) 'cons 'list*) + #-x86-64 'list*) + (scs (operand-parse-scs (vop-parse-more-args - (gethash 'list* *backend-parsed-vops*)))) + (gethash vopname *backend-parsed-vops*)))) (allow-const ;; Make sure the backend allows both of IMMEDIATE ;; and CONSTANT since MAKE-CONSTANT-TN could produce either. @@ -2088,7 +2093,10 @@ not stack-allocated LVAR ~S." source-lvar))))) (when (and lvar (lvar-dynamic-extent lvar)) (vop current-stack-pointer node block (ir2-lvar-stack-pointer (lvar-info lvar)))) - (vop* list* node block (refs) ((first res) nil) n-cons-cells star) + ;; VOP* requires a literal name, thus this CASE expression + (case vopname + #+x86-64 (cons (vop* cons node block (refs) ((first res) nil) n-cons-cells star)) + (list* (vop* list* node block (refs) ((first res) nil) n-cons-cells star))) (move-lvar-result node block res lvar)))))) (setf (fun-info-ir2-convert (fun-info-or-lose 'cons)) #'list*-ir2-convert-optimizer) (setf (fun-info-ir2-convert (fun-info-or-lose 'list)) #'list*-ir2-convert-optimizer) diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp index 34faf8f7e..90bac3317 100644 --- a/src/compiler/x86-64/alloc.lisp +++ b/src/compiler/x86-64/alloc.lisp @@ -59,11 +59,12 @@ (used-p (sb-c::ir2-component-wired-tns comp)))))))) ;;; Call an allocator trampoline and get the result in the proper register. -;;; There are 2x2 choices of trampoline: +;;; For lists there are 2 choices of trampoline: +;;; - preserve YMM registers around the call, or don't +;;; For everything else there are 2x2 choices of trampoline: ;;; - place result into R11, or leave it on the stack ;;; - preserve YMM registers around the call, or don't (defun %alloc-tramp (type node result-tn size lowtag) - (declare (ignorable type)) (when (typep size 'integer) (aver (= (align-up size (* 2 n-word-bytes)) size))) (cond ((typep size '(and integer (not (signed-byte 32)))) @@ -76,15 +77,17 @@ ;; that returns a result in TEMP-REG-TN (R11) which saves one move and ;; clears the size argument from the stack in the RET instruction. ;; If the result is returned on the stack, then we pop it below. - (let ((to-r11 (location= result-tn r11-tn))) - (invoke-asm-routine 'call - (cond #+avx2 - ((avx-registers-used-p) - (if to-r11 'alloc->r11.ymmsave 'alloc->rnn.ymmsave)) - (t - (if to-r11 'alloc->r11 'alloc->rnn))) - node) - (unless to-r11 + (let* ((to-r11 (location= result-tn r11-tn)) + (entrypoint + (if (eq type 'list) + (cond #+avx2 ((avx-registers-used-p) 'list*.ymmsave) + (t 'list*)) + (cond #+avx2 ((avx-registers-used-p) + (if to-r11 'alloc->r11.ymmsave 'alloc->rnn.ymmsave)) + (t + (if to-r11 'alloc->r11 'alloc->rnn)))))) + (invoke-asm-routine 'call entrypoint node) + (when (or (eq type 'list) (not to-r11)) (inst pop result-tn))) (unless (eql lowtag 0) (inst or :byte result-tn lowtag))) @@ -150,6 +153,7 @@ #-sb-thread (ea (+ boxed-region n-word-bytes)))) (cond ((typep size `(integer ,large-object-size)) + (aver (neq type 'list)) ;; large objects will never be made in a per-thread region (%alloc-tramp type node alloc-tn size lowtag)) ((eql lowtag 0) @@ -218,16 +222,24 @@ (inst or :byte result-tn other-pointer-lowtag)))))) ;;;; CONS, LIST and LIST* -(define-vop (list*) +(define-vop (cons) ; need only 1 declared temp, and can make 1 or 2 conses (:args (things :more t :scs (descriptor-reg constant immediate))) - (:temporary (:sc unsigned-reg) ptr temp) (:temporary (:sc unsigned-reg :to (:result 0) :target result) res) (:info cons-cells star) (:results (result :scs (descriptor-reg))) (:node-var node) - (:generator 0 - (macrolet ((store-slot (tn list &optional (slot cons-car-slot) - (lowtag list-pointer-lowtag)) + (:generator 0 (generate-list* node cons-cells star things result res nil))) +(define-vop (list*) ; need 2 declared temps, make any number of conses + (:args (things :more t :scs (descriptor-reg constant immediate))) + (:temporary (:sc unsigned-reg) ptr) + (:temporary (:sc unsigned-reg :to (:result 0) :target result) res) + (:info cons-cells star) + (:results (result :scs (descriptor-reg))) + (:node-var node) + (:generator 0 (generate-list* node cons-cells star things result res ptr))) +(defun generate-list* (node cons-cells star things result res ptr) + (macrolet ((store-slot (tn list &optional (slot cons-car-slot) + (lowtag list-pointer-lowtag)) `(let ((reg ;; FIXME: single-float gets placed in the boxed header ;; rather than just doing an immediate store. @@ -238,20 +250,19 @@ (t (encode-value-if-immediate ,tn))))) (storew* reg ,list ,slot ,lowtag (not stack-allocate-p))))) - (let ((stack-allocate-p (node-stack-allocate-p node)) - (size (* (pad-data-block cons-size) cons-cells))) - (unless stack-allocate-p - (instrument-alloc size node)) - (pseudo-atomic (:elide-if stack-allocate-p) - (allocation nil size (if (<= cons-cells 2) 0 list-pointer-lowtag) - node stack-allocate-p res) - (multiple-value-bind (last-base-reg lowtag car cdr) - (cond - ((= cons-cells 1) + (let ((stack-allocate-p (node-stack-allocate-p node)) + (temp temp-reg-tn) + (size (* (pad-data-block cons-size) cons-cells))) + (unless stack-allocate-p + (instrument-alloc size node)) + (pseudo-atomic (:elide-if stack-allocate-p) + (aver (not (location= res temp-reg-tn))) + (allocation 'list size (if (<= cons-cells 2) 0 list-pointer-lowtag) + node stack-allocate-p res) + (multiple-value-bind (last-base-reg lowtag car cdr) + (cond ((= cons-cells 1) (values res 0 cons-car-slot cons-cdr-slot)) ((= cons-cells 2) - ;; Note that this does not use the 'ptr' register at all. - ;; It would require a different vop to free that register up. (store-slot (tn-ref-tn things) res cons-car-slot 0) (setf things (tn-ref-across things)) (inst lea temp (ea (+ (* cons-size n-word-bytes) list-pointer-lowtag) res)) @@ -279,7 +290,7 @@ (inst lea result (ea list-pointer-lowtag res)))) (t (move result res))))))) - (aver (null (tn-ref-across things))))) + (aver (null (tn-ref-across things)))) ;;;; special-purpose inline allocators