Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
compare: stack-packing-trick
Checking mergeability… Don't worry, you can still create the pull request.
  • 4 commits
  • 5 files changed
  • 0 commit comments
  • 1 contributor
Commits on Jun 28, 2013
@pkhuong pkhuong Disentangle storage base initial size from growth increments
Before, an initial stack frame size of 8 meant that the stack frame
always grew in increments of 8. Not only is a large initial size bad
for GC (it leaves more dead references untouched), but a large increment
is even worse.
@pkhuong pkhuong Smaller stack frames on x86oids
Start at 4 slots (for some reason, it seems that 3 isn't really
the minimum, and grows by one slot at a time.
@pkhuong pkhuong Grow regalloc datastructures geometrically for unbounded SCs 1d3d077
@pkhuong pkhuong Pack (mostly) stack TNs according to lexical scope information
 Packing TNs from shallow scopes before more deeply nested one
 is a perfect elimination order when the live ranges span the
 full scope.  Use that as a heuristic, and do that for TNs that
 are known to have such simple live ranges before the rest:
 this ensures that bad TNs don't mess everything up.

 Incidentally: fix catch block packing on win32, solving lp#1072739
12 src/compiler/meta-vmdef.lisp
@@ -27,7 +27,8 @@
;;; We enter the basic structure at meta-compile time, and then fill
;;; in the missing slots at load time.
-(defmacro define-storage-base (name kind &key size)
+(defmacro define-storage-base (name kind &key size (size-increment size)
+ (size-alignment 1))
(declare (type symbol name))
(declare (type (member :finite :unbounded :non-packed) kind))
@@ -39,11 +40,16 @@
(error "A size specification is meaningless in a ~S SB." kind)))
((:finite :unbounded)
(unless size (error "Size is not specified in a ~S SB." kind))
- (aver (typep size 'unsigned-byte))))
+ (aver (typep size 'unsigned-byte))
+ (aver (= 1 (logcount size-alignment)))
+ (aver (not (logtest size (1- size-alignment))))
+ (aver (not (logtest size-increment (1- size-alignment))))))
(let ((res (if (eq kind :non-packed)
(make-sb :name name :kind kind)
- (make-finite-sb :name name :kind kind :size size))))
+ (make-finite-sb :name name :kind kind :size size
+ :size-increment size-increment
+ :size-alignment size-alignment))))
(eval-when (:compile-toplevel :load-toplevel :execute)
101 src/compiler/pack.lisp
@@ -215,24 +215,26 @@
(let* ((sb (sc-sb sc))
(size (finite-sb-current-size sb))
(align-mask (1- (sc-alignment sc)))
- (inc (max (sb-size sb)
+ (inc (max (finite-sb-size-increment sb)
(+ (sc-element-size sc)
(- (logandc2 (+ size align-mask) align-mask)
(- needed-size size)))
- (new-size (+ size inc))
+ (new-size (let ((align-mask (1- (finite-sb-size-alignment sb))))
+ (logandc2 (+ size inc align-mask) align-mask)))
(conflicts (finite-sb-conflicts sb))
(block-size (if (zerop (length conflicts))
(ir2-block-count *component-being-compiled*)
- (length (the simple-vector (svref conflicts 0))))))
- (declare (type index inc new-size))
+ (length (the simple-vector (svref conflicts 0)))))
+ (padded-size (ash 1 (integer-length (1- new-size)))))
+ (declare (type index inc new-size padded-size))
(aver (eq (sb-kind sb) :unbounded))
- (when (> new-size (length conflicts))
- (let ((new-conf (make-array new-size)))
+ (when (> padded-size (length conflicts))
+ (let ((new-conf (make-array padded-size)))
(replace new-conf conflicts)
(do ((i size (1+ i)))
- ((= i new-size))
+ ((= i padded-size))
(declare (type index i))
(let ((loc-confs (make-array block-size)))
(dotimes (j block-size)
@@ -243,23 +245,23 @@
(setf (svref new-conf i) loc-confs)))
(setf (finite-sb-conflicts sb) new-conf))
- (let ((new-live (make-array new-size)))
+ (let ((new-live (make-array padded-size)))
(replace new-live (finite-sb-always-live sb))
(do ((i size (1+ i)))
- ((= i new-size))
+ ((= i padded-size))
(setf (svref new-live i)
(make-array block-size
:initial-element 0
:element-type 'bit)))
(setf (finite-sb-always-live sb) new-live))
- (let ((new-live-count (make-array new-size)))
+ (let ((new-live-count (make-array padded-size)))
(declare (optimize speed)) ;; FILL deftransform
(replace new-live-count (finite-sb-always-live-count sb))
(fill new-live-count 0 :start size)
(setf (finite-sb-always-live-count sb) new-live-count))
- (let ((new-tns (make-array new-size :initial-element nil)))
+ (let ((new-tns (make-array padded-size :initial-element nil)))
(replace new-tns (finite-sb-live-tns sb))
(fill (finite-sb-live-tns sb) nil)
(setf (finite-sb-live-tns sb) new-tns)))
@@ -1349,7 +1351,7 @@
;;; If we are attempting to pack in the SC of the save TN for a TN
;;; with a :SPECIFIED-SAVE TN, then we pack in that location, instead
;;; of allocating a new stack location.
-(defun pack-tn (tn restricted optimize)
+(defun pack-tn (tn restricted optimize &key (allow-unbounded-sc t))
(declare (type tn tn))
(let* ((original (original-tn tn))
(fsc (tn-sc tn))
@@ -1362,12 +1364,15 @@
(do ((sc fsc (pop alternates)))
((null sc)
(failed-to-pack-error tn restricted))
+ (unless (or allow-unbounded-sc
+ (neq (sb-kind (sc-sb sc)) :unbounded))
+ (return nil))
(when (eq sc specified-save-sc)
(unless (tn-offset save)
(pack-tn save nil optimize))
(setf (tn-offset tn) (tn-offset save))
(setf (tn-sc tn) (tn-sc save))
- (return))
+ (return t))
(when (or restricted
(not (and (minusp (tn-cost tn)) (sc-save-p sc))))
(let ((loc (or (find-ok-target-offset original sc)
@@ -1382,7 +1387,7 @@
(add-location-conflicts original sc loc optimize)
(setf (tn-sc tn) sc)
(setf (tn-offset tn) loc)
- (return))))))
+ (return t))))))
;;; Pack a wired TN, checking that the offset is in bounds for the SB,
@@ -1494,6 +1499,31 @@
(setf (finite-sb-live-tns sb)
(make-array size :initial-element nil))))))
+(defun tn-lexical-depth (tn)
+ (let ((path t)) ; dummy initial value
+ (labels ((path (lambda)
+ (nreverse (loop while lambda
+ collect lambda
+ do (setf lambda (lambda-parent lambda)))))
+ (register-scope (lambda)
+ (let ((new-path (path lambda)))
+ (setf path (if (eql path t)
+ new-path
+ (subseq path
+ 0 (mismatch path new-path))))))
+ (walk-tn-refs (ref)
+ (do ((ref ref (tn-ref-next ref)))
+ ((null ref))
+ (binding* ((node (vop-node (tn-ref-vop ref))
+ :exit-if-null))
+ (register-scope (lexenv-lambda
+ (node-lexenv node)))))))
+ (walk-tn-refs (tn-reads tn))
+ (walk-tn-refs (tn-writes tn))
+ (if (eql path t)
+ most-positive-fixnum
+ (length path)))))
(defun pack (component)
(let ((optimize nil)
@@ -1549,7 +1579,8 @@
(assign-tn-depths component))
;; Allocate normal TNs, starting with the TNs that are used
- ;; in deep loops.
+ ;; in deep loops. Only allocate in finite SCs (i.e. not on
+ ;; the stack).
(collect ((tns))
(do-ir2-blocks (block component)
(let ((ltns (ir2-block-local-tns block)))
@@ -1564,7 +1595,7 @@
;; well revert to the old behaviour of just
;; packing TNs linearly as they appear.
(unless *loop-analyze*
- (pack-tn tn nil optimize))
+ (pack-tn tn nil optimize :allow-unbounded-sc nil))
(tns tn))))))
(dolist (tn (stable-sort (tns)
(lambda (a b)
@@ -1577,14 +1608,36 @@
(> (tn-cost a) (tn-cost b)))
(t nil)))))
(unless (tn-offset tn)
- (pack-tn tn nil optimize))))
- ;; Pack any leftover normal TNs. This is to deal with :MORE TNs,
- ;; which could possibly not appear in any local TN map.
- (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
- ((null tn))
- (unless (tn-offset tn)
- (pack-tn tn nil optimize)))
+ (pack-tn tn nil optimize :allow-unbounded-sc nil))))
+ ;; Pack any leftover normal TNs that could not be allocated
+ ;; to finite SCs, or TNs that do not appear in any local TN
+ ;; map (e.g. :MORE TNs). Since we'll likely be allocating
+ ;; on the stack, first allocate TNs that are associated with
+ ;; code at shallow lexical depths: this will allocate long
+ ;; live ranges (i.e. TNs with more conflicts) first, and
+ ;; hopefully minimise stack fragmentation.
+ ;;
+ ;; Collect in reverse order to give priority to older TNs.
+ (let ((contiguous-tns '())
+ (tns '()))
+ (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
+ ((null tn))
+ (unless (tn-offset tn)
+ (let ((key (cons tn (tn-lexical-depth tn))))
+ (if (memq (tn-kind tn) '(:environment :debug-environment
+ :component))
+ (push key contiguous-tns)
+ (push key tns)))))
+ (flet ((pack-tns (tns)
+ (dolist (tn (stable-sort tns #'< :key #'cdr))
+ (let ((tn (car tn)))
+ (unless (tn-offset tn)
+ (pack-tn tn nil optimize))))))
+ ;; first pack TNs that are known to have simple
+ ;; live ranges (contiguous lexical scopes)
+ (pack-tns contiguous-tns)
+ (pack-tns tns)))
;; Do load TN packing and emit saves.
(let ((*repack-blocks* nil))
7 src/compiler/vop.lisp
@@ -765,6 +765,12 @@
;;; A FINITE-SB holds information needed by the packing algorithm for
;;; finite SBs.
(def!struct (finite-sb (:include sb))
+ ;; the minimum number of location by which to grow this SB
+ ;; if it is :unbounded
+ (size-increment 1 :type index)
+ ;; current-size must always be a multiple of this. It is assumed
+ ;; to be a power of two.
+ (size-alignment 1 :type index)
;; the number of locations currently allocated in this SB
(current-size 0 :type index)
;; the last location packed in, used by pack to scatter TNs to
@@ -855,6 +861,7 @@
;; true if this SC or one of its alternates in in the NUMBER-STACK SB.
(number-stack-p nil :type boolean)
;; alignment restriction. The offset must be an even multiple of this.
+ ;; this must be a power of two.
(alignment 1 :type (and index (integer 1)))
;; a list of locations that we avoid packing in during normal
;; register allocation to ensure that these locations will be free
2  src/compiler/x86-64/vm.lisp
@@ -187,7 +187,7 @@
(define-storage-base float-registers :finite :size 16)
-(define-storage-base stack :unbounded :size 8)
+(define-storage-base stack :unbounded :size 4 :size-increment 1)
(define-storage-base constant :non-packed)
(define-storage-base immediate-constant :non-packed)
(define-storage-base noise :unbounded :size 2)
2  src/compiler/x86/vm.lisp
@@ -118,7 +118,7 @@
;;; the new way:
(define-storage-base float-registers :finite :size 8)
-(define-storage-base stack :unbounded :size 8)
+(define-storage-base stack :unbounded :size 4 :size-increment 1)
(define-storage-base constant :non-packed)
(define-storage-base immediate-constant :non-packed)
(define-storage-base noise :unbounded :size 2)

No commit comments for this range

Something went wrong with that request. Please try again.