DYNAMIC-EXTENT &REST lists.
... much as per CSR sbcl-devel 2004-03-29;
... alter listify-rest-args VOPs on non-x86 to meet the new use
(don't do anything yet with the DX parameter)
... note concerns over stack manipulation in x86 DX allocation
This version compiles and passes tests on x86 and alpha (modulo
one unrelated bugfix, coming soon)
the readtable currently in effect.
changes in sbcl-0.8.10 relative to sbcl-0.8.9:
+ * [placeholder for DX summary]
+ ** user code with &REST lists declared dynamic-extent, under high
+ speed or space and low safety and debug optimization policy.
* bug fix: compiler emitted division in optimized DEREF. (thanks for
the test case to Dave Roberts)
* bug fix: multidimensional simple arrays loaded from FASLs had fill
Others not so much, but in sbcl-0.7.0 I put some effort into
making them more consistent.
ARG argument
+ DX dynamic-extent
FUN function
GC garbage collect(ion)
N new: number, as in e.g. N-PASSES or N-WORD-BITS
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
(count-arg :target count :scs (any-reg)))
- (:arg-types * tagged-num)
+ (:info dx)
+ (:ignore dx)
+ (:arg-types * tagged-num (:constant t))
(:temporary (:scs (any-reg) :from (:argument 0)) context)
(:temporary (:scs (any-reg) :from (:argument 1)) count)
(:temporary (:scs (descriptor-reg) :from :eval) temp dst)
(defknown %cleanup-point () t)
(defknown %special-bind (t t) t)
(defknown %special-unbind (t) t)
-(defknown %listify-rest-args (t index) list (flushable))
+(defknown %dynamic-extent-start () t)
+(defknown %dynamic-extent-end () t)
+(defknown %listify-rest-args (t index t) list (flushable))
(defknown %more-arg-context (t t) (values t index) (flushable))
(defknown %more-arg (t index) t)
(defknown %more-arg-values (t index index) * (flushable))
-(in-package "SB!VM")
+;;;; the VM definition of function call for the HPPA
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+(in-package "SB!VM")
\f
;;;; Interfaces to IR2 conversion:
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
(count-arg :target count :scs (any-reg)))
- (:arg-types * tagged-num)
+ (:info dx)
+ (:ignore dx)
+ (:arg-types * tagged-num (:constant t))
(:temporary (:scs (any-reg) :from (:argument 0)) context)
(:temporary (:scs (any-reg) :from (:argument 1)) count)
(:temporary (:scs (descriptor-reg) :from :eval) temp)
(rest svars))))))
(values))
+;;; FIXME: this is the interface of the CMUCL WITH-DYNAMIC-EXTENT
+;;; macro. It is slightly confusing, in that START and BODY-START are
+;;; already-existing CTRANs (and FIXME: probably deserve a ONCE-ONLY),
+;;; whereas NEXT is a variable naming a CTRAN in the body. -- CSR,
+;;; 2004-03-30.
+(defmacro with-dynamic-extent ((start body-start next kind) &body body)
+ (with-unique-names (cleanup next-ctran)
+ `(progn
+ (ctran-starts-block ,body-start)
+ (let ((,cleanup (make-cleanup :kind :dynamic-extent))
+ (,next-ctran (make-ctran))
+ (,next (make-ctran)))
+ (ir1-convert ,start ,next-ctran nil '(%dynamic-extent-start))
+ (setf (cleanup-mess-up ,cleanup) (ctran-use ,next-ctran))
+ (let ((*lexenv* (make-lexenv :cleanup ,cleanup)))
+ (ir1-convert ,next-ctran ,next nil '(%cleanup-point))
+ (locally ,@body))))))
+
;;; Create a lambda node out of some code, returning the result. The
;;; bindings are specified by the list of VAR structures VARS. We deal
;;; with adding the names to the LEXENV-VARS for the conversion. The
;;; the special binding code.
;;;
;;; We ignore any ARG-INFO in the VARS, trusting that someone else is
-;;; dealing with &nonsense.
+;;; dealing with &NONSENSE, except for &REST vars with DYNAMIC-EXTENT.
;;;
;;; AUX-VARS is a list of VAR structures for variables that are to be
;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated
:%source-name source-name
:%debug-name debug-name))
(result-ctran (make-ctran))
- (result-lvar (make-lvar)))
+ (result-lvar (make-lvar))
+ (dx-rest nil))
(awhen (lexenv-lambda *lexenv*)
(push lambda (lambda-children it))
(t
(when note-lexical-bindings
(note-lexical-binding (leaf-source-name var)))
- (new-venv (cons (leaf-source-name var) var))))))
+ (new-venv (cons (leaf-source-name var) var)))))
+ (let ((info (lambda-var-arg-info var)))
+ (when (and info
+ (eq (arg-info-kind info) :rest)
+ (leaf-dynamic-extent var))
+ (setq dx-rest t))))
(let ((*lexenv* (make-lexenv :vars (new-venv)
:lambda lambda
(ctran-starts-block prebind-ctran)
(link-node-to-previous-ctran bind prebind-ctran)
(use-ctran bind postbind-ctran)
- (ir1-convert-special-bindings postbind-ctran result-ctran result-lvar
- body
- aux-vars aux-vals (svars))))))
+ (if dx-rest
+ (with-dynamic-extent (postbind-ctran result-ctran dx :rest)
+ (ir1-convert-special-bindings dx result-ctran result-lvar
+ body aux-vars aux-vals
+ (svars)))
+ (ir1-convert-special-bindings postbind-ctran result-ctran
+ result-lvar body
+ aux-vars aux-vals (svars)))))))
(link-blocks (component-head *current-component*) (node-block bind))
(push lambda (component-new-functionals *current-component*))
(arg-vars context-temp count-temp)
(when rest
- (arg-vals `(%listify-rest-args ,n-context ,n-count)))
+ (arg-vals `(%listify-rest-args
+ ,n-context ,n-count ,(leaf-dynamic-extent rest))))
(when morep
(arg-vals n-context)
(arg-vals n-count))
(setf (lambda-var-ignorep var) t)))))
(values))
+(defun process-dx-decl (names vars)
+ (flet ((maybe-notify (control &rest args)
+ (when (policy *lexenv* (> speed inhibit-warnings))
+ (apply #'compiler-notify control args))))
+ (if (policy *lexenv* (= stack-allocate-dynamic-extent 3))
+ (dolist (name names)
+ (cond
+ ((symbolp name)
+ (let* ((bound-var (find-in-bindings vars name))
+ (var (or bound-var
+ (lexenv-find name vars)
+ (find-free-var name))))
+ (etypecase var
+ (leaf
+ (if bound-var
+ (setf (leaf-dynamic-extent var) t)
+ (maybe-notify
+ "ignoring DYNAMIC-EXTENT declaration for free ~S"
+ name)))
+ (cons
+ (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+ (heap-alien-info
+ (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S"
+ name)))))
+ ((and (consp name)
+ (eq (car name) 'function)
+ (null (cddr name))
+ (valid-function-name-p (cadr name)))
+ (maybe-notify "ignoring DYNAMIC-EXTENT declaration for ~S" name))
+ (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
+ (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names))))
+
;;; FIXME: This is non-ANSI, so the default should be T, or it should
;;; go away, I think.
(defvar *suppress-values-declaration* nil
`(values ,@types)))))
res))
(dynamic-extent
- (when (policy *lexenv* (> speed inhibit-warnings))
- (compiler-notify
- "compiler limitation: ~
- ~% There's no special support for DYNAMIC-EXTENT (so it's ignored)."))
+ (process-dx-decl (cdr spec) vars)
res)
(t
(unless (info :declaration :recognized (first spec))
(defoptimizer (%special-unbind ir2-convert) ((var) node block)
(vop unbind node block))
+(defoptimizer (%dynamic-extent-start ir2-convert) (() node block) node block)
+(defoptimizer (%dynamic-extent-end ir2-convert) (() node block) node block)
+
;;; ### It's not clear that this really belongs in this file, or
;;; should really be done this way, but this is the least violation of
;;; abstraction in the current setup. We don't want to wire
-(in-package "SB!VM")
+;;;; the VM definition of function call for MIPS
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+(in-package "SB!VM")
\f
;;;; Interfaces to IR2 conversion:
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
(count-arg :target count :scs (any-reg)))
- (:arg-types * tagged-num)
+ (:info dx)
+ (:ignore dx)
+ (:arg-types * tagged-num (:constant t))
(:temporary (:scs (any-reg) :from (:argument 0)) context)
(:temporary (:scs (any-reg) :from (:argument 1)) count)
(:temporary (:scs (descriptor-reg) :from :eval) temp dst)
(defstruct (cleanup (:copier nil))
;; the kind of thing that has to be cleaned up
(kind (missing-arg)
- :type (member :special-bind :catch :unwind-protect :block :tagbody))
+ :type (member :special-bind :catch :unwind-protect
+ :block :tagbody :dynamic-extent))
;; the node that messes things up. This is the last node in the
;; non-messed-up environment. Null only temporarily. This could be
;; deleted due to unreachability.
;; true if there was ever a REF or SET node for this leaf. This may
;; be true when REFS and SETS are null, since code can be deleted.
(ever-used nil :type boolean)
+ ;; is it declared dynamic-extent?
+ (dynamic-extent nil :type boolean)
;; some kind of info used by the back end
(info nil))
(code `(%funcall ,fun))))
((:block :tagbody)
(dolist (nlx (cleanup-nlx-info cleanup))
- (code `(%lexical-exit-breakup ',nlx)))))))
+ (code `(%lexical-exit-breakup ',nlx))))
+ (:dynamic-extent
+ (code `(%dynamic-extent-end))))))
(when (code)
(aver (not (node-tail-p (block-last block1))))
3
0)
("no" "maybe" "yes" "yes"))
+
+(define-optimization-quality stack-allocate-dynamic-extent
+ (if (and (> (max speed space) (max debug safety))
+ (< safety 3))
+ 3
+ 0)
+ ("no" "maybe" "yes" "yes"))
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
(count-arg :target count :scs (any-reg)))
- (:arg-types * tagged-num)
+ (:info dx)
+ (:ignore dx)
+ (:arg-types * tagged-num (:constant t))
(:temporary (:scs (any-reg) :from (:argument 0)) context)
(:temporary (:scs (any-reg) :from (:argument 1)) count)
(:temporary (:scs (descriptor-reg) :from :eval) temp)
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
(count-arg :target count :scs (any-reg)))
- (:arg-types * tagged-num)
+ (:info dx)
+ (:ignore dx)
+ (:arg-types * tagged-num (:constant t))
(:temporary (:scs (any-reg) :from (:argument 0)) context)
(:temporary (:scs (any-reg) :from (:argument 1)) count)
(:temporary (:scs (descriptor-reg) :from :eval) temp)
(:policy :safe)
(:args (context :scs (descriptor-reg) :target src)
(count :scs (any-reg) :target ecx))
- (:arg-types * tagged-num)
+ (:info *dynamic-extent*)
+ (:arg-types * tagged-num (:constant t))
(:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 0)) src)
(:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
(:temporary (:sc unsigned-reg :offset eax-offset) eax)
(inst jecxz done)
(inst lea dst (make-ea :dword :index ecx :scale 2))
(pseudo-atomic
- (allocation dst dst node)
+ (allocation dst dst node *dynamic-extent*)
(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.
(defvar *maybe-use-inline-allocation* t) ; FIXME unused
;;; Emit code to allocate an object with a size in bytes given by
-;;; Size. The size may be an integer of a TN. If Inline is a VOP
+;;; SIZE. The size may be an integer of a TN. If Inline is a VOP
;;; node-var then it is used to make an appropriate speed vs size
;;; decision.
-;;; This macro should only be used inside a pseudo-atomic section,
-;;; which should also cover subsequent initialization of the
-;;; object.
-(defun allocation (alloc-tn size &optional inline)
- ;; FIXME: since it appears that inline allocation is gone, we should
- ;; remove the INLINE parameter and *MAYBE-USE-INLINE-ALLOCATION*
- (declare (ignore inline))
+(defun allocation-dynamic-extent (alloc-tn size)
+ (inst sub esp-tn size)
+ ;; FIXME: SIZE _should_ be double-word aligned (suggested but
+ ;; unfortunately not enforced by PAD-DATA-BLOCK and
+ ;; WITH-FIXED-ALLOCATION), so that ESP is always divisible by 8 (for
+ ;; 32-bit lispobjs). In that case, this AND instruction is
+ ;; unneccessary and could be removed. If not, explain why. -- CSR,
+ ;; 2004-03-30
+ (inst and esp-tn #.(ldb (byte 32 0) (lognot lowtag-mask)))
+ (aver (not (location= alloc-tn esp-tn)))
+ (inst mov alloc-tn esp-tn)
+ (values))
+
+(defun allocation-notinline (alloc-tn size)
(flet ((load-size (dst-tn size)
(unless (and (tn-p size) (location= alloc-tn size))
(inst mov dst-tn size))))
(t
(load-size edi-tn size)
(inst call (make-fixup (extern-alien-name "alloc_to_edi")
- :foreign))))))))
+ :foreign)))))))))
+
+;;; This macro should only be used inside a pseudo-atomic section,
+;;; which should also cover subsequent initialization of the object.
+;;; (FIXME: so why aren't we asserting this?)
+(defun allocation (alloc-tn size &optional inline dynamic-extent)
+ ;; FIXME: since it appears that inline allocation is gone, we should
+ ;; remove the INLINE parameter and *MAYBE-USE-INLINE-ALLOCATION*
+ (declare (ignore inline))
+ (cond
+ (dynamic-extent (allocation-dynamic-extent alloc-tn size))
+ (t (allocation-notinline alloc-tn size)))
(values))
;;; Allocate an other-pointer object of fixed SIZE with a single word
;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
;;; 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.
+;;;
+;;; KLUDGE: since the stack on the x86 is treated conservatively, it
+;;; does not matter whether a signal occurs during construction of a
+;;; dynamic-extent object, as the half-finished construction of the
+;;; object will not cause any difficulty. We can therefore elide
+(defvar *dynamic-extent* nil)
#!+sb-thread
(defmacro pseudo-atomic (&rest forms)
(with-unique-names (label)
- `(let ((,label (gen-label)))
- (inst fs-segment-prefix)
- (inst mov (make-ea :byte
- :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
- (inst fs-segment-prefix)
- (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1)
- ,@forms
- (inst fs-segment-prefix)
- (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 0)
- (inst fs-segment-prefix)
- (inst cmp (make-ea :byte
- :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
- (inst jmp :eq ,label)
- ;; if PAI was set, interrupts were disabled at the same time
- ;; using the process signal mask.
- (inst break pending-interrupt-trap)
- (emit-label ,label))))
+ `(if *dynamic-extent* ; I will burn in hell
+ (progn ,@forms)
+ (let ((,label (gen-label)))
+ (inst fs-segment-prefix)
+ (inst mov (make-ea :byte
+ :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
+ (inst fs-segment-prefix)
+ (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1)
+ ,@forms
+ (inst fs-segment-prefix)
+ (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 0)
+ (inst fs-segment-prefix)
+ (inst cmp (make-ea :byte
+ :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
+ (inst jmp :eq ,label)
+ ;; if PAI was set, interrupts were disabled at the same
+ ;; time using the process signal mask.
+ (inst break pending-interrupt-trap)
+ (emit-label ,label)))))
#!-sb-thread
(defmacro pseudo-atomic (&rest forms)
(with-unique-names (label)
- `(let ((,label (gen-label)))
- ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
- ;; something. (perhaps SVLB, for static variable low byte)
- (inst mov (make-ea :byte :disp (+ nil-value
- (static-symbol-offset
- '*pseudo-atomic-interrupted*)
- (ash symbol-value-slot word-shift)
- ;; FIXME: Use mask, not minus, to
- ;; take out type bits.
- (- other-pointer-lowtag)))
- 0)
- (inst mov (make-ea :byte :disp (+ nil-value
- (static-symbol-offset
- '*pseudo-atomic-atomic*)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag)))
- (fixnumize 1))
- ,@forms
- (inst mov (make-ea :byte :disp (+ nil-value
- (static-symbol-offset
- '*pseudo-atomic-atomic*)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag)))
- 0)
- ;; KLUDGE: Is there any requirement for interrupts to be
- ;; handled in order? It seems as though an interrupt coming
- ;; in at this point will be executed before any pending interrupts.
- ;; Or do incoming interrupts check to see whether any interrupts
- ;; are pending? I wish I could find the documentation for
- ;; pseudo-atomics.. -- WHN 19991130
- (inst cmp (make-ea :byte
- :disp (+ nil-value
- (static-symbol-offset
- '*pseudo-atomic-interrupted*)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag)))
- 0)
- (inst jmp :eq ,label)
- ;; if PAI was set, interrupts were disabled at the same time
- ;; using the process signal mask.
- (inst break pending-interrupt-trap)
- (emit-label ,label))))
-
-
+ `(if *dynamic-extent*
+ (progn ,@forms)
+ (let ((,label (gen-label)))
+ ;; FIXME: The MAKE-EA noise should become a MACROLET macro
+ ;; or something. (perhaps SVLB, for static variable low
+ ;; byte)
+ (inst mov (make-ea :byte :disp (+ nil-value
+ (static-symbol-offset
+ '*pseudo-atomic-interrupted*)
+ (ash symbol-value-slot word-shift)
+ ;; FIXME: Use mask, not minus, to
+ ;; take out type bits.
+ (- other-pointer-lowtag)))
+ 0)
+ (inst mov (make-ea :byte :disp (+ nil-value
+ (static-symbol-offset
+ '*pseudo-atomic-atomic*)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag)))
+ (fixnumize 1))
+ ,@forms
+ (inst mov (make-ea :byte :disp (+ nil-value
+ (static-symbol-offset
+ '*pseudo-atomic-atomic*)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag)))
+ 0)
+ ;; KLUDGE: Is there any requirement for interrupts to be
+ ;; handled in order? It seems as though an interrupt coming
+ ;; in at this point will be executed before any pending
+ ;; interrupts. Or do incoming interrupts check to see
+ ;; whether any interrupts are pending? I wish I could find
+ ;; the documentation for pseudo-atomics.. -- WHN 19991130
+ (inst cmp (make-ea :byte
+ :disp (+ nil-value
+ (static-symbol-offset
+ '*pseudo-atomic-interrupted*)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag)))
+ 0)
+ (inst jmp :eq ,label)
+ ;; if PAI was set, interrupts were disabled at the same
+ ;; time using the process signal mask.
+ (inst break pending-interrupt-trap)
+ (emit-label ,label)))))
\f
;;;; indexed references
;;; 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.8.9.9"
+"0.8.9.10"
projects / sbcl.git / commitdiff