From 04bc82d1f1c692029c9821acea9dbf295e7628fd Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 16 Jun 2005 14:48:00 +0000 Subject: [PATCH] 0.9.1.48: Implement (most of) the dynamic-extent vops on x86-64. ... no support for vectors yet. --- NEWS | 3 +++ src/compiler/x86-64/alloc.lisp | 13 +++++++++---- src/compiler/x86-64/call.lisp | 11 +++++++---- src/compiler/x86-64/macros.lisp | 19 ++++++++++++++++++- tests/dynamic-extent.impure.lisp | 2 +- version.lisp-expr | 2 +- 6 files changed, 39 insertions(+), 11 deletions(-) diff --git a/NEWS b/NEWS index 79e1224..b0a8820 100644 --- a/NEWS +++ b/NEWS @@ -34,6 +34,9 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1: * optimization: structure instances with raw slots now use less memory, and probably show better memory locality. (thanks to David Lichteblau) + * optimization: DYNAMIC-EXTENT declarations for lists and closures + are treated as requests for stack allocation on the x86-64 + platform. * contrib improvement: it's harder to cause SOCKET-CLOSE to close() the wrong file descriptor; implementation of SOCKET-OPEN-P. (thanks to Tony Martinez) diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp index cf91584..f15e19e 100644 --- a/src/compiler/x86-64/alloc.lisp +++ b/src/compiler/x86-64/alloc.lisp @@ -12,6 +12,10 @@ (in-package "SB!VM") ;;;; LIST and LIST* +(defoptimizer (list stack-allocate-result) ((&rest args)) + (not (null args))) +(defoptimizer (list* stack-allocate-result) ((&rest args)) + (not (null (rest args)))) (define-vop (list-or-list*) (:args (things :more t)) @@ -40,7 +44,9 @@ (storew reg ,list ,slot list-pointer-lowtag)))) (let ((cons-cells (if star (1- num) num))) (pseudo-atomic - (allocation res (* (pad-data-block cons-size) cons-cells) node) + (allocation res (* (pad-data-block cons-size) cons-cells) node + (awhen (sb!c::node-lvar node) + (sb!c::lvar-dynamic-extent it))) (inst lea res (make-ea :byte :base res :disp list-pointer-lowtag)) (move ptr res) @@ -111,14 +117,13 @@ (define-vop (make-closure) (:args (function :to :save :scs (descriptor-reg))) (:info length stack-allocate-p) - (:ignore stack-allocate-p) (:temporary (:sc any-reg) temp) (:results (result :scs (descriptor-reg))) (:node-var node) (:generator 10 - (pseudo-atomic + (maybe-pseudo-atomic stack-allocate-p (let ((size (+ length closure-info-offset))) - (allocation result (pad-data-block size) node) + (allocation result (pad-data-block size) node stack-allocate-p) (inst lea result (make-ea :byte :base result :disp fun-pointer-lowtag)) (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag) diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp index abff23f..e1a1267 100644 --- a/src/compiler/x86-64/call.lisp +++ b/src/compiler/x86-64/call.lisp @@ -1248,8 +1248,10 @@ (inst mov value (make-ea :qword :base object :disp (- (* index n-word-bytes)))))) - ;;; Turn more arg (context, count) into a list. +(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args)) + t) + (define-vop (listify-rest-args) (:translate %listify-rest-args) (:policy :safe) @@ -1265,15 +1267,16 @@ (:generator 20 (let ((enter (gen-label)) (loop (gen-label)) - (done (gen-label))) + (done (gen-label)) + (stack-allocate-p (node-stack-allocate-p node))) (move src context) (move rcx count) ;; Check to see whether there are no args, and just return NIL if so. (inst mov result nil-value) (inst jecxz done) (inst lea dst (make-ea :qword :index rcx :scale 2)) - (pseudo-atomic - (allocation dst dst node) + (maybe-pseudo-atomic stack-allocate-p + (allocation dst dst node stack-allocate-p) (inst lea dst (make-ea :byte :base dst :disp list-pointer-lowtag)) ;; Convert the count into a raw value, so that we can use the ;; LOOP instruction. diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp index 625b496..29601b5 100644 --- a/src/compiler/x86-64/macros.lisp +++ b/src/compiler/x86-64/macros.lisp @@ -124,6 +124,14 @@ ;;; node-var then it is used to make an appropriate speed vs size ;;; decision. +(defun allocation-dynamic-extent (alloc-tn size) + (inst sub rsp-tn size) + ;; see comment in x86/macros.lisp implementation of this + (inst and rsp-tn #.(lognot lowtag-mask)) + (aver (not (location= alloc-tn rsp-tn))) + (inst mov alloc-tn rsp-tn) + (values)) + ;;; This macro should only be used inside a pseudo-atomic section, ;;; which should also cover subsequent initialization of the ;;; object. @@ -136,8 +144,11 @@ (inst pop alloc-tn) (values)) -(defun allocation (alloc-tn size &optional ignored) +(defun allocation (alloc-tn size &optional ignored dynamic-extent) (declare (ignore ignored)) + (when dynamic-extent + (allocation-dynamic-extent alloc-tn size) + (return-from allocation (values))) (let ((NOT-INLINE (gen-label)) (DONE (gen-label)) ;; Yuck. @@ -258,6 +269,12 @@ ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check ;;; the C flag after the shift to see whether you were interrupted. +;;; FIXME: THIS NAME IS BACKWARDS! +(defmacro maybe-pseudo-atomic (really-p &body body) + `(if ,really-p + (progn ,@body) + (pseudo-atomic ,@body))) + (defmacro pseudo-atomic (&rest forms) (with-unique-names (label) `(let ((,label (gen-label))) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index cb436c3..ece03b1 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -100,7 +100,7 @@ (funcall thunk)) (assert (< (- (get-bytes-consed) before) times)))) -#+x86 +#+(or x86 x86-64) (progn (assert-no-consing (dxlength 1 2 3)) (assert-no-consing (dxlength t t t t t t)) diff --git a/version.lisp-expr b/version.lisp-expr index 012990a..0391c3e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.1.47" +"0.9.1.48" -- 1.7.10.4