mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
0.8.13-dx.2:
* Differ UVL and DX LVARs in IR1 component printout. * %LISTIFY-REST-ARGS treats DX in the same way as LIST. * Replace (SETF (FUN-INFO-STACK-ALLOCATE-RESULT ...)) with DEFOPTIMIZER. * DEFOPTIMIZER interns FUN-INFO-* into SB[!-]C. * Physenv analysis does not insert %DYNAMIC-EXTENT-END when not needed. * Pull Christophe[?] out of hell: replace *DYNAMIC-EXTENT* hack with MAYBE-PSEUDO-ATOMIC macro. * Changed representation of LVAR-DYNAMIC-EXTENT: now it is a CLEANUP or NULL. * LET-variable substitution does not break stack allocation. * DX propagation in SUBSTITUTE-LVAR-USES.
This commit is contained in:
Alexey Dejneka
parent
c57b46945b
commit
073fc2ae57
|
|
@ -190,3 +190,36 @@ through TYPEP UNBOXED-ARRAY, within the compiler itself.
|
|||
rather than either constant-folding or manipulating NIL-VALUE or
|
||||
NULL-TN directly.
|
||||
--------------------------------------------------------------------------------
|
||||
#19
|
||||
(let ((dx (if (foo)
|
||||
(list x)
|
||||
(list y z))))
|
||||
(declare (dynamic-extent dx))
|
||||
...)
|
||||
|
||||
DX is not allocated on stack.
|
||||
--------------------------------------------------------------------------------
|
||||
#20
|
||||
(defun-with-dx foo (x)
|
||||
(flet ((make (x)
|
||||
(let ((l (list nil nil)))
|
||||
(setf (first l) x)
|
||||
(setf (second l) (1- x))
|
||||
l)))
|
||||
(let ((l (make x)))
|
||||
(declare (dynamic-extent l))
|
||||
(mapc #'print l))))
|
||||
|
||||
Result of MAKE is not stack allocated, which means that
|
||||
stack-allocation of structures is impossible.
|
||||
--------------------------------------------------------------------------------
|
||||
#21
|
||||
(defun-with-dx foo ()
|
||||
(let ((dx (list (list 1 2) (list 3 4)
|
||||
(declare (dynamic-extent dx))
|
||||
...)))))
|
||||
|
||||
External list in DX is allocated on stack, but internal are not.
|
||||
--------------------------------------------------------------------------------
|
||||
#22
|
||||
IR2 does not perform unused code flushing.
|
||||
|
|
|
|||
|
|
@ -267,6 +267,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
|
|||
"MULTIPLE-CALL-VARIABLE"
|
||||
"%%NIP-DX" "%%NIP-VALUES"
|
||||
"NLX-ENTRY" "NLX-ENTRY-MULTIPLE"
|
||||
"NODE-STACK-ALLOCATE-P"
|
||||
"NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START"
|
||||
"NOTE-THIS-LOCATION" "OPTIMIZER" "PACK-TRACE-TABLE"
|
||||
"PARSE-EVAL-WHEN-SITUATIONS"
|
||||
|
|
|
|||
|
|
@ -1109,8 +1109,6 @@ default-value-8
|
|||
(define-vop (listify-rest-args)
|
||||
(:args (context-arg :target context :scs (descriptor-reg))
|
||||
(count-arg :target count :scs (any-reg)))
|
||||
(: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)
|
||||
|
|
|
|||
|
|
@ -941,6 +941,11 @@
|
|||
(format t "v~D " (cont-num cont))
|
||||
(values))
|
||||
|
||||
(defun print-lvar-stack (stack &optional (stream *standard-output*))
|
||||
(loop for (lvar . rest) on stack
|
||||
do (format stream "~:[u~;d~]v~D~@[ ~]"
|
||||
(lvar-dynamic-extent lvar) (cont-num lvar) rest)))
|
||||
|
||||
;;; Print out the nodes in BLOCK in a format oriented toward
|
||||
;;; representing what the code does.
|
||||
(defun print-nodes (block)
|
||||
|
|
@ -953,8 +958,8 @@
|
|||
|
||||
(pprint-newline :mandatory)
|
||||
(awhen (block-info block)
|
||||
(format t "start stack:~{ v~D~}"
|
||||
(mapcar #'cont-num (ir2-block-start-stack it)))
|
||||
(format t "start stack: ")
|
||||
(print-lvar-stack (ir2-block-start-stack it))
|
||||
(pprint-newline :mandatory))
|
||||
(do ((ctran (block-start block) (node-next (ctran-next ctran))))
|
||||
((not ctran))
|
||||
|
|
@ -996,7 +1001,13 @@
|
|||
(print-lvar (return-result node))
|
||||
(print-leaf (return-lambda node)))
|
||||
(entry
|
||||
(format t "entry ~S" (entry-exits node)))
|
||||
(let ((cleanup (entry-cleanup node)))
|
||||
(case (cleanup-kind cleanup)
|
||||
((:dynamic-extent)
|
||||
(format t "entry DX~{ v~D~}"
|
||||
(mapcar #'cont-num (cleanup-info cleanup))))
|
||||
(t
|
||||
(format t "entry ~S" (entry-exits node))))))
|
||||
(exit
|
||||
(let ((value (exit-value node)))
|
||||
(cond (value
|
||||
|
|
@ -1015,8 +1026,8 @@
|
|||
(pprint-newline :mandatory)))
|
||||
|
||||
(awhen (block-info block)
|
||||
(format t "end stack:~{ v~D~}"
|
||||
(mapcar #'cont-num (ir2-block-end-stack it)))
|
||||
(format t "end stack: ")
|
||||
(print-lvar-stack (ir2-block-end-stack it))
|
||||
(pprint-newline :mandatory))
|
||||
(let ((succ (block-succ block)))
|
||||
(format t "successors~{ c~D~}~%"
|
||||
|
|
|
|||
|
|
@ -1365,7 +1365,7 @@
|
|||
(defknown %special-unbind (t) t)
|
||||
(defknown %dynamic-extent-start () t)
|
||||
(defknown %dynamic-extent-end () t)
|
||||
(defknown %listify-rest-args (t index t) list (flushable))
|
||||
(defknown %listify-rest-args (t index) 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))
|
||||
|
|
|
|||
|
|
@ -1078,8 +1078,6 @@ default-value-8
|
|||
(define-vop (listify-rest-args)
|
||||
(:args (context-arg :target context :scs (descriptor-reg))
|
||||
(count-arg :target count :scs (any-reg)))
|
||||
(: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)
|
||||
|
|
|
|||
|
|
@ -1314,7 +1314,8 @@
|
|||
(dest (lvar-dest lvar)))
|
||||
(when (and
|
||||
;; Think about (LET ((A ...)) (IF ... A ...)): two
|
||||
;; LVAR-USEs should not be met on one path.
|
||||
;; LVAR-USEs should not be met on one path. Another problem
|
||||
;; is with dynamic-extent.
|
||||
(eq (lvar-uses lvar) ref)
|
||||
(typecase dest
|
||||
;; we should not change lifetime of unknown values lvars
|
||||
|
|
@ -1339,7 +1340,9 @@
|
|||
(eq (node-home-lambda ref)
|
||||
(lambda-home (lambda-var-home var))))
|
||||
(setf (node-derived-type ref) *wild-type*)
|
||||
(substitute-lvar-uses lvar arg)
|
||||
(substitute-lvar-uses lvar arg
|
||||
;; Really it is (EQ (LVAR-USES LVAR) REF):
|
||||
t)
|
||||
(delete-lvar-use ref)
|
||||
(change-ref-leaf ref (find-constant nil))
|
||||
(delete-ref ref)
|
||||
|
|
|
|||
|
|
@ -255,25 +255,6 @@
|
|||
(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)
|
||||
(declare (ignore kind))
|
||||
(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
|
||||
|
|
@ -310,8 +291,7 @@
|
|||
:%source-name source-name
|
||||
:%debug-name debug-name))
|
||||
(result-ctran (make-ctran))
|
||||
(result-lvar (make-lvar))
|
||||
(dx-rest nil))
|
||||
(result-lvar (make-lvar)))
|
||||
|
||||
(awhen (lexenv-lambda *lexenv*)
|
||||
(push lambda (lambda-children it))
|
||||
|
|
@ -341,12 +321,7 @@
|
|||
(t
|
||||
(when note-lexical-bindings
|
||||
(note-lexical-binding (leaf-source-name 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))))
|
||||
(new-venv (cons (leaf-source-name var) var))))))
|
||||
|
||||
(let ((*lexenv* (make-lexenv :vars (new-venv)
|
||||
:lambda lambda
|
||||
|
|
@ -371,14 +346,9 @@
|
|||
(ctran-starts-block prebind-ctran)
|
||||
(link-node-to-previous-ctran bind prebind-ctran)
|
||||
(use-ctran bind postbind-ctran)
|
||||
(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)))))))
|
||||
aux-vars aux-vals (svars))))))
|
||||
|
||||
(link-blocks (component-head *current-component*) (node-block bind))
|
||||
(push lambda (component-new-functionals *current-component*))
|
||||
|
|
@ -545,7 +515,7 @@
|
|||
|
||||
(when rest
|
||||
(arg-vals `(%listify-rest-args
|
||||
,n-context ,n-count ,(leaf-dynamic-extent rest))))
|
||||
,n-context ,n-count)))
|
||||
(when morep
|
||||
(arg-vals n-context)
|
||||
(arg-vals n-count))
|
||||
|
|
|
|||
|
|
@ -164,16 +164,27 @@
|
|||
(values))
|
||||
|
||||
;;; Replace all uses of OLD with uses of NEW, where NEW has an
|
||||
;;; arbitary number of uses.
|
||||
(defun substitute-lvar-uses (new old)
|
||||
;;; arbitary number of uses. NEW is supposed to be "later" than OLD.
|
||||
(defun substitute-lvar-uses (new old propagate-dx)
|
||||
(declare (type lvar old)
|
||||
(type (or lvar null) new))
|
||||
(type (or lvar null) new)
|
||||
(type boolean propagate-dx))
|
||||
|
||||
(cond (new (do-uses (node old)
|
||||
(cond (new
|
||||
(do-uses (node old)
|
||||
(%delete-lvar-use node)
|
||||
(add-lvar-use node new))
|
||||
(reoptimize-lvar new))
|
||||
(reoptimize-lvar new)
|
||||
(awhen (and propagate-dx (lvar-dynamic-extent old))
|
||||
(setf (lvar-dynamic-extent old) nil)
|
||||
(unless (lvar-dynamic-extent new)
|
||||
(setf (lvar-dynamic-extent new) it)
|
||||
(setf (cleanup-info it) (substitute new old (cleanup-info it)))))
|
||||
(when (lvar-dynamic-extent new)
|
||||
(do-uses (node new)
|
||||
(node-ends-block node))))
|
||||
(t (flush-dest old)))
|
||||
|
||||
(values))
|
||||
|
||||
;;;; block starting/creation
|
||||
|
|
@ -305,8 +316,9 @@
|
|||
(when (and (basic-combination-p use)
|
||||
(eq (basic-combination-kind use) :local))
|
||||
(merges use))))
|
||||
(substitute-lvar-uses lvar value
|
||||
(and lvar (eq (lvar-uses lvar) node)))
|
||||
(%delete-lvar-use node)
|
||||
(substitute-lvar-uses lvar value)
|
||||
(prog1
|
||||
(unlink-node node)
|
||||
(dolist (merge (merges))
|
||||
|
|
@ -342,6 +354,11 @@
|
|||
(defun node-dest (node)
|
||||
(awhen (node-lvar node) (lvar-dest it)))
|
||||
|
||||
#!-sb-fluid (declaim (inline node-stack-allocate-p))
|
||||
(defun node-stack-allocate-p (node)
|
||||
(awhen (node-lvar node)
|
||||
(lvar-dynamic-extent it)))
|
||||
|
||||
(declaim (inline block-to-be-deleted-p))
|
||||
(defun block-to-be-deleted-p (block)
|
||||
(or (block-delete-p block)
|
||||
|
|
|
|||
|
|
@ -1611,14 +1611,7 @@
|
|||
(move-lvar-result node block res lvar)))))
|
||||
(def list)
|
||||
(def list*))
|
||||
(setf (fun-info-stack-allocate-result (info :function :info 'list))
|
||||
(lambda (call)
|
||||
(declare (type combination call))
|
||||
(not (null (combination-args call)))))
|
||||
(setf (fun-info-stack-allocate-result (info :function :info 'list*))
|
||||
(lambda (call)
|
||||
(declare (type combination call))
|
||||
(not (null (rest (combination-args call))))))
|
||||
|
||||
|
||||
;;; Convert the code in a component into VOPs.
|
||||
(defun ir2-convert (component)
|
||||
|
|
|
|||
|
|
@ -47,16 +47,16 @@
|
|||
(declare (type combination call) (type clambda fun))
|
||||
(loop for arg in (basic-combination-args call)
|
||||
and var in (lambda-vars fun)
|
||||
when (lambda-var-dynamic-extent var)
|
||||
when (and (lambda-var-dynamic-extent var)
|
||||
(not (lvar-dynamic-extent arg)))
|
||||
collect arg into dx-lvars
|
||||
and do (progn (setf (lvar-dynamic-extent arg) t)
|
||||
;; Stack analysis wants DX value generators to
|
||||
;; end their blocks. Uses of mupltiple used
|
||||
;; LVARs already end their blocks, so we just
|
||||
;; need to process used-once LVARs.
|
||||
(let ((use (lvar-uses arg)))
|
||||
and do (let ((use (lvar-uses arg)))
|
||||
;; Stack analysis wants DX value generators to end
|
||||
;; their blocks. Uses of mupltiple used LVARs already
|
||||
;; end their blocks, so we just need to process
|
||||
;; used-once LVARs.
|
||||
(when (node-p use)
|
||||
(node-ends-block use))))
|
||||
(node-ends-block use)))
|
||||
finally (when dx-lvars
|
||||
(binding* ((before-ctran (node-prev call))
|
||||
(nil (ensure-block-start before-ctran))
|
||||
|
|
@ -77,7 +77,9 @@
|
|||
(setf (node-lexenv call)
|
||||
(make-lexenv :default (node-lexenv call)
|
||||
:cleanup cleanup))
|
||||
(push entry (lambda-entries (node-home-lambda entry))))))
|
||||
(push entry (lambda-entries (node-home-lambda entry)))
|
||||
(dolist (lvar dx-lvars)
|
||||
(setf (lvar-dynamic-extent lvar) cleanup)))))
|
||||
(values))
|
||||
|
||||
;;; This function handles merging the tail sets if CALL is potentially
|
||||
|
|
@ -884,7 +886,8 @@
|
|||
;; FIXME: Replace the call with unsafe CAST. -- APD, 2003-01-26
|
||||
(do-uses (use result)
|
||||
(derive-node-type use call-type)))
|
||||
(substitute-lvar-uses lvar result)))
|
||||
(substitute-lvar-uses lvar result
|
||||
(and lvar (eq (lvar-uses lvar) call)))))
|
||||
(values))
|
||||
|
||||
;;; We are converting FUN to be a LET when the call is in a non-tail
|
||||
|
|
|
|||
|
|
@ -508,7 +508,8 @@
|
|||
,(parse-deftransform lambda-list body n-args
|
||||
`(return-from ,name nil))))
|
||||
,@(when (consp what)
|
||||
`((setf (,(symbolicate "FUN-INFO-" (second what))
|
||||
`((setf (,(let ((*package* (symbol-package 'sb!c::fun-info)))
|
||||
(symbolicate "FUN-INFO-" (second what)))
|
||||
(fun-info-or-lose ',(first what)))
|
||||
#',name)))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1109,8 +1109,6 @@ default-value-8
|
|||
(define-vop (listify-rest-args)
|
||||
(:args (context-arg :target context :scs (descriptor-reg))
|
||||
(count-arg :target count :scs (any-reg)))
|
||||
(: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)
|
||||
|
|
|
|||
|
|
@ -76,9 +76,10 @@
|
|||
;; Cached type which is checked by DEST. If NIL, then this must be
|
||||
;; recomputed: see LVAR-EXTERNALLY-CHECKABLE-TYPE.
|
||||
(%externally-checkable-type nil :type (or null ctype))
|
||||
;; if the LVAR value is DYNAMIC-EXTENT, CLEANUP protecting it.
|
||||
(dynamic-extent nil :type (or null cleanup))
|
||||
;; something or other that the back end annotates this lvar with
|
||||
(info nil)
|
||||
(dynamic-extent nil :type boolean))
|
||||
(info nil))
|
||||
|
||||
(def!method print-object ((x lvar) stream)
|
||||
(print-unreadable-object (x stream :type t :identity t)
|
||||
|
|
|
|||
|
|
@ -391,7 +391,8 @@
|
|||
(dolist (nlx (cleanup-nlx-info cleanup))
|
||||
(code `(%lexical-exit-breakup ',nlx))))
|
||||
(:dynamic-extent
|
||||
(code `(%dynamic-extent-end))))))
|
||||
(when (not (null (cleanup-info cleanup)))
|
||||
(code `(%dynamic-extent-end)))))))
|
||||
|
||||
(when (code)
|
||||
(aver (not (node-tail-p (block-last block1))))
|
||||
|
|
|
|||
|
|
@ -1100,8 +1100,6 @@ default-value-8
|
|||
(define-vop (listify-rest-args)
|
||||
(:args (context-arg :target context :scs (descriptor-reg))
|
||||
(count-arg :target count :scs (any-reg)))
|
||||
(: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)
|
||||
|
|
|
|||
|
|
@ -1073,8 +1073,6 @@ default-value-8
|
|||
(define-vop (listify-rest-args)
|
||||
(:args (context-arg :target context :scs (descriptor-reg))
|
||||
(count-arg :target count :scs (any-reg)))
|
||||
(: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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -1260,13 +1260,15 @@
|
|||
|
||||
|
||||
;;; 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)
|
||||
(:args (context :scs (descriptor-reg) :target src)
|
||||
(count :scs (any-reg) :target ecx))
|
||||
(:info *dynamic-extent*)
|
||||
(:arg-types * tagged-num (:constant t))
|
||||
(:arg-types * tagged-num)
|
||||
(: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)
|
||||
|
|
@ -1276,15 +1278,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 ecx 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 :dword :index ecx :scale 2))
|
||||
(pseudo-atomic
|
||||
(allocation dst dst node *dynamic-extent*)
|
||||
(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.
|
||||
|
|
|
|||
|
|
@ -135,7 +135,7 @@
|
|||
;;; eventually invoke the C alloc() function. Once upon a time
|
||||
;;; (before threads) allocation within an alloc_region could also be
|
||||
;;; done inline, with the aid of two C symbols storing the current
|
||||
;;; allocation region boundaries; however, C symbols are global.
|
||||
;;; allocation region boundaries; however, C cymbols are global.
|
||||
|
||||
;;; C calls for allocation don't /seem/ to make an awful lot of
|
||||
;;; difference to speed. Guessing from historical context, it looks
|
||||
|
|
@ -143,7 +143,14 @@
|
|||
;;; which time all calls to alloc() would have needed a syscall to
|
||||
;;; mask signals for the duration. Now we have pseudoatomic there's
|
||||
;;; no need for that overhead. Still, inline alloc would be a neat
|
||||
;;; addition someday (except see below).
|
||||
;;; addition someday
|
||||
|
||||
(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
|
||||
;;; node-var then it is used to make an appropriate speed vs size
|
||||
;;; decision.
|
||||
|
||||
(defun allocation-dynamic-extent (alloc-tn size)
|
||||
(inst sub esp-tn size)
|
||||
|
|
@ -159,83 +166,84 @@
|
|||
(values))
|
||||
|
||||
(defun allocation-notinline (alloc-tn size)
|
||||
(let* ((alloc-tn-offset (tn-offset alloc-tn))
|
||||
(flet ((load-size (dst-tn size)
|
||||
(unless (and (tn-p size) (location= alloc-tn size))
|
||||
(inst mov dst-tn size))))
|
||||
(let ((alloc-tn-offset (tn-offset alloc-tn)))
|
||||
;; C call to allocate via dispatch routines. Each
|
||||
;; destination has a special entry point. The size may be a
|
||||
;; register or a constant.
|
||||
(tn-text (ecase alloc-tn-offset
|
||||
(#.eax-offset "eax")
|
||||
(#.ecx-offset "ecx")
|
||||
(#.edx-offset "edx")
|
||||
(#.ebx-offset "ebx")
|
||||
(#.esi-offset "esi")
|
||||
(#.edi-offset "edi")))
|
||||
(size-text (case size (8 "8_") (16 "16_") (t ""))))
|
||||
(unless (or (eql size 8) (eql size 16))
|
||||
(unless (and (tn-p size) (location= alloc-tn size))
|
||||
(inst mov alloc-tn size)))
|
||||
(inst call (make-fixup (extern-alien-name
|
||||
(concatenate 'string
|
||||
"alloc_" size-text
|
||||
"to_" tn-text))
|
||||
:foreign))))
|
||||
|
||||
(defun allocation-inline (alloc-tn size)
|
||||
(let ((ok (gen-label))
|
||||
(free-pointer
|
||||
(make-ea :dword :disp
|
||||
#!+sb-thread (* n-word-bytes thread-alloc-region-slot)
|
||||
#!-sb-thread (make-fixup (extern-alien-name "boxed_region")
|
||||
:foreign)
|
||||
:scale 1)) ; thread->alloc_region.free_pointer
|
||||
(end-addr
|
||||
(make-ea :dword :disp
|
||||
#!+sb-thread (* n-word-bytes (1+ thread-alloc-region-slot))
|
||||
#!-sb-thread (make-fixup (extern-alien-name "boxed_region")
|
||||
:foreign 4)
|
||||
:scale 1))) ; thread->alloc_region.end_addr
|
||||
(unless (and (tn-p size) (location= alloc-tn size))
|
||||
(inst mov alloc-tn size))
|
||||
#!+sb-thread (inst fs-segment-prefix)
|
||||
(inst add alloc-tn free-pointer)
|
||||
#!+sb-thread (inst fs-segment-prefix)
|
||||
(inst cmp alloc-tn end-addr)
|
||||
(inst jmp :be OK)
|
||||
(let ((dst (ecase (tn-offset alloc-tn)
|
||||
(#.eax-offset "alloc_overflow_eax")
|
||||
(#.ecx-offset "alloc_overflow_ecx")
|
||||
(#.edx-offset "alloc_overflow_edx")
|
||||
(#.ebx-offset "alloc_overflow_ebx")
|
||||
(#.esi-offset "alloc_overflow_esi")
|
||||
(#.edi-offset "alloc_overflow_edi"))))
|
||||
(inst call (make-fixup (extern-alien-name dst) :foreign)))
|
||||
(emit-label ok)
|
||||
#!+sb-thread (inst fs-segment-prefix)
|
||||
(inst xchg free-pointer alloc-tn))
|
||||
(values))
|
||||
|
||||
|
||||
;;; Emit code to allocate an object with a size in bytes given by
|
||||
;;; SIZE. The size may be an integer or a TN. If Inline is a VOP
|
||||
;;; node-var then it is used to make an appropriate speed vs size
|
||||
;;; decision.
|
||||
|
||||
;;; Allocation should only be used inside a pseudo-atomic section, which
|
||||
;;; should also cover subsequent initialization of the object.
|
||||
(ecase alloc-tn-offset
|
||||
(#.eax-offset
|
||||
(case size
|
||||
(8 (inst call (make-fixup (extern-alien-name "alloc_8_to_eax")
|
||||
:foreign)))
|
||||
(16 (inst call (make-fixup (extern-alien-name "alloc_16_to_eax")
|
||||
:foreign)))
|
||||
(t
|
||||
(load-size eax-tn size)
|
||||
(inst call (make-fixup (extern-alien-name "alloc_to_eax")
|
||||
:foreign)))))
|
||||
(#.ecx-offset
|
||||
(case size
|
||||
(8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ecx")
|
||||
:foreign)))
|
||||
(16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ecx")
|
||||
:foreign)))
|
||||
(t
|
||||
(load-size ecx-tn size)
|
||||
(inst call (make-fixup (extern-alien-name "alloc_to_ecx")
|
||||
:foreign)))))
|
||||
(#.edx-offset
|
||||
(case size
|
||||
(8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edx")
|
||||
:foreign)))
|
||||
(16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edx")
|
||||
:foreign)))
|
||||
(t
|
||||
(load-size edx-tn size)
|
||||
(inst call (make-fixup (extern-alien-name "alloc_to_edx")
|
||||
:foreign)))))
|
||||
(#.ebx-offset
|
||||
(case size
|
||||
(8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ebx")
|
||||
:foreign)))
|
||||
(16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ebx")
|
||||
:foreign)))
|
||||
(t
|
||||
(load-size ebx-tn size)
|
||||
(inst call (make-fixup (extern-alien-name "alloc_to_ebx")
|
||||
:foreign)))))
|
||||
(#.esi-offset
|
||||
(case size
|
||||
(8 (inst call (make-fixup (extern-alien-name "alloc_8_to_esi")
|
||||
:foreign)))
|
||||
(16 (inst call (make-fixup (extern-alien-name "alloc_16_to_esi")
|
||||
:foreign)))
|
||||
(t
|
||||
(load-size esi-tn size)
|
||||
(inst call (make-fixup (extern-alien-name "alloc_to_esi")
|
||||
:foreign)))))
|
||||
(#.edi-offset
|
||||
(case size
|
||||
(8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edi")
|
||||
:foreign)))
|
||||
(16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edi")
|
||||
:foreign)))
|
||||
(t
|
||||
(load-size edi-tn size)
|
||||
(inst call (make-fixup (extern-alien-name "alloc_to_edi")
|
||||
: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))
|
||||
;; FIXME: for reasons unknown, inline allocation is a speed win on
|
||||
;; non-P4s, and a speed loss on P4s (and probably other such
|
||||
;; high-spec high-cache machines). :INLINE-ALLOCATION-IS-GOOD is
|
||||
;; a bit of a KLUDGE, really. -- CSR, 2004-08-05 (following
|
||||
;; observations made by ASF and Juho Snellman)
|
||||
((and (member :inline-allocation-is-good *backend-subfeatures*)
|
||||
(or (null inline) (policy inline (>= speed space))))
|
||||
(allocation-inline alloc-tn size))
|
||||
(t (allocation-notinline alloc-tn size)))
|
||||
(values))
|
||||
|
||||
|
|
@ -313,14 +321,15 @@
|
|||
;;; 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)
|
||||
(defmacro maybe-pseudo-atomic (really-p &body forms)
|
||||
`(if ,really-p
|
||||
(progn ,@forms)
|
||||
(pseudo-atomic ,@forms)))
|
||||
|
||||
#!+sb-thread
|
||||
(defmacro pseudo-atomic (&rest forms)
|
||||
(with-unique-names (label)
|
||||
`(if *dynamic-extent* ; I will burn in hell
|
||||
(progn ,@forms)
|
||||
(let ((,label (gen-label)))
|
||||
`(let ((,label (gen-label)))
|
||||
(inst fs-segment-prefix)
|
||||
(inst mov (make-ea :byte
|
||||
:disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
|
||||
|
|
@ -336,14 +345,12 @@
|
|||
;; if PAI was set, interrupts were disabled at the same
|
||||
;; time using the process signal mask.
|
||||
(inst break pending-interrupt-trap)
|
||||
(emit-label ,label)))))
|
||||
(emit-label ,label))))
|
||||
|
||||
#!-sb-thread
|
||||
(defmacro pseudo-atomic (&rest forms)
|
||||
(with-unique-names (label)
|
||||
`(if *dynamic-extent*
|
||||
(progn ,@forms)
|
||||
(let ((,label (gen-label)))
|
||||
`(let ((,label (gen-label)))
|
||||
;; FIXME: The MAKE-EA noise should become a MACROLET macro
|
||||
;; or something. (perhaps SVLB, for static variable low
|
||||
;; byte)
|
||||
|
|
@ -385,7 +392,7 @@
|
|||
;; if PAI was set, interrupts were disabled at the same
|
||||
;; time using the process signal mask.
|
||||
(inst break pending-interrupt-trap)
|
||||
(emit-label ,label)))))
|
||||
(emit-label ,label))))
|
||||
|
||||
;;;; indexed references
|
||||
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@
|
|||
(assert (= (dxcaller 1 2 3 4 5 6 7) 22))
|
||||
|
||||
;;; %NIP-VALUES
|
||||
(defun-with-dx foo ()
|
||||
(defun-with-dx test-nip-values ()
|
||||
(flet ((bar (x &rest y)
|
||||
(declare (dynamic-extent y))
|
||||
(if (> x 0)
|
||||
|
|
@ -47,6 +47,41 @@
|
|||
(bar 1 2 3 4 5 6)
|
||||
(bar -1 'a 'b))))
|
||||
|
||||
(assert (equal (foo) '(1 5 a)))
|
||||
(assert (equal (test-nip-values) '(1 5 a)))
|
||||
|
||||
;;; LET-variable substitution
|
||||
(defun-with-dx test-let-var-subst1 (x)
|
||||
(let ((y (list x (1- x))))
|
||||
(print :foo)
|
||||
(let ((z (the list y)))
|
||||
(declare (dynamic-extent z))
|
||||
(length z))))
|
||||
(assert (eql (test-let-var-subst1 17) 2))
|
||||
|
||||
(defun-with-dx test-let-var-subst2 (x)
|
||||
(let ((y (list x (1- x))))
|
||||
(declare (dynamic-extent y))
|
||||
(print :foo)
|
||||
(let ((z (the list y)))
|
||||
(length z))))
|
||||
(assert (eql (test-let-var-subst2 17) 2))
|
||||
|
||||
;;; DX propagation through LET-return.
|
||||
(defun-with-dx test-lvar-subst (x)
|
||||
(let ((y (list x (1- x))))
|
||||
(declare (dynamic-extent y))
|
||||
(second (let ((z (the list y)))
|
||||
(print :foo)
|
||||
z))))
|
||||
(assert (eql (test-lvar-subst 11) 10))
|
||||
|
||||
;;; this code is incorrect, but the compiler should not fail
|
||||
(defun-with-dx test-let-var-subst-incorrect (x)
|
||||
(let ((y (list x (1- x))))
|
||||
(print :foo)
|
||||
(let ((z (the list y)))
|
||||
(declare (dynamic-extent z))
|
||||
(print :bar)
|
||||
z)))
|
||||
|
||||
(sb-ext:quit :unix-status 104)
|
||||
|
|
@ -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.8.13-dx.1"
|
||||
"0.8.13-dx.2"
|
||||
|
|
|
|||
Loading…
Reference in a new issue