common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Fix list* vop

Browse source
This commit is contained in:
Douglas Katzman 2021-06-29 00:00:10 -04:00
parent d1a28ee585
commit 41520f928e
4 changed files with 73 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
src/assembly/x86-64/tramps.lisp
View file

@ -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

15
src/compiler/generic/objdef.lisp
View file

@ -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.

14
src/compiler/ir2tran.lisp
View file

@ -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)

47
src/compiler/x86-64/alloc.lisp
View file

@ -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)
(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)))
node)
(unless to-r11
(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,14 +222,22 @@
(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
(: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
@ -239,19 +251,18 @@
(encode-value-if-immediate ,tn)))))
(storew* reg ,list ,slot ,lowtag (not stack-allocate-p)))))
(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)
(allocation nil size (if (<= cons-cells 2) 0 list-pointer-lowtag)
(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)
(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