From ef010f84cf933dea73e5df97a3066d935127bc48 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Mon, 24 Aug 1992 14:28:18 +0000 Subject: [PATCH] Lots of changes to the schedular: instead of using lists for sets and alists for mappings, use ssets and simple-vectors. In define-instruction, have one piece of code that computes both the read and write dependencies at once instead of having two difference pieces of code that build lists of each. --- compiler/new-assem.lisp | 389 +++++++++++++++++++--------------------- 1 file changed, 189 insertions(+), 200 deletions(-) diff --git a/compiler/new-assem.lisp b/compiler/new-assem.lisp index 3ea99dfba..8df313974 100644 --- a/compiler/new-assem.lisp +++ b/compiler/new-assem.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.16 1992/07/31 00:22:20 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.17 1992/08/24 14:28:18 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -17,12 +17,16 @@ ;;; (in-package :new-assem) -(import 'c:branch) -(import 'c:flushable) +(in-package :c) +(import '(branch flushable) :new-assem) +(import '(sset-element sset make-sset do-elements + sset-adjoin sset-delete sset-empty) + :new-assem) +(in-package :new-assem) (export '(emit-byte emit-skip emit-back-patch emit-chooser emit-postit define-emitter define-instruction define-instruction-macro - def-assembler-params branch flushable + def-assembler-params branch flushable reads writes segment make-segment segment-name assemble align inst without-scheduling @@ -37,7 +41,8 @@ (:print-function %print-assem-params)) (backend (ext:required-argument) :type c::backend) (scheduler-p nil :type (member t nil)) - (instructions (make-hash-table :test #'equal) :type hash-table)) + (instructions (make-hash-table :test #'equal) :type hash-table) + (max-locations 0 :type index)) ;;; (c::defprinter assem-params (backend :prin1 (c:backend-name backend))) @@ -161,13 +166,20 @@ ;; List of postit's. These are accumulated between instructions. (postits nil :type list) ;; - ;; A-lists mapping locations to the instruction that reads them and - ;; instructions that write them. If maintaining these as a-lists is - ;; too expensive (consing, time, or whatever) we could represent this - ;; information in a slot in the location. But then the scheduler would not - ;; be re-enterent. - (readers nil :type list) - (writers nil :type list) + ;; ``Number'' for last instruction queued. Used only to supply insts + ;; with unique sset-element-number's. + (inst-number 0 :type index) + ;; + ;; Simple-Vectors mapping locations to the instruction that reads them and + ;; instructions that write them. + (readers (make-array (assem-params-max-locations + (c:backend-assembler-params c:*backend*)) + :initial-element nil) + :type simple-vector) + (writers (make-array (assem-params-max-locations + (c:backend-assembler-params c:*backend*)) + :initial-element nil) + :type simple-vector) ;; ;; The number of additional cycles before the next control transfer, or NIL ;; if a control transfer hasn't been queued. When a delayed branch is @@ -177,11 +189,11 @@ ;; *** These two slots are used both by the queuing noise and the ;; scheduling noise. ;; - ;; A list of all the instructions that are pending and don't have any - ;; unresolved dependents. We don't list branches here even if they would - ;; otherwise qualify. They are listed above. + ;; All the instructions that are pending and don't have any unresolved + ;; dependents. We don't list branches here even if they would otherwise + ;; qualify. They are listed above. ;; - (emittable-insts nil :type list) + (emittable-insts-sset (make-sset) :type sset) ;; ;; List of queued branches. We handle these specially, because they have to ;; be emitted at a specific place (e.g. one slot before the end of the @@ -195,7 +207,10 @@ ;; top level list corresponds to yet another cycle of delay. Each element ;; in the second level lists is a dotted pair, holding the dependency ;; instruction and the dependent to remove. - (delayed nil :type list)) + (delayed nil :type list) + ;; + ;; The emittable insts again, except this time as a list sorted by depth. + (emittable-insts-queue nil :type list)) (c::defprinter segment name) @@ -216,9 +231,10 @@ ) (defstruct (instruction + (:include sset-element) (:print-function %print-instruction) (:conc-name inst-) - (:constructor make-instruction (emitter attributes delay))) + (:constructor make-instruction (number emitter attributes delay))) ;; ;; The function to envoke to actually emit this instruction. Gets called ;; with the segment as its one argument. @@ -240,18 +256,17 @@ ;; ``read'' or ``write'' always referes to the dependent (second) ;; instruction. ;; - ;; List of the instructions whos writes this instruction tries to read. - (read-dependencies nil :type list) + ;; Instructions whos writes this instruction tries to read. + (read-dependencies (make-sset) :type sset) ;; - ;; List of the instructions whos writes or reads are overwritten by this - ;; instruction. - (write-dependencies nil :type list) + ;; Instructions whos writes or reads are overwritten by this instruction. + (write-dependencies (make-sset) :type sset) ;; - ;; List of the instructions who write what we read or write. - (write-dependents nil :type list) + ;; Instructions who write what we read or write. + (write-dependents (make-sset) :type sset) ;; - ;; List of the instrucitons who read what we write. - (read-dependents nil :type list)) + ;; Instructions who read what we write. + (read-dependents (make-sset) :type sset)) ;;; #+debug (defvar *inst-ids* (make-hash-table :test #'eq)) #+debug (defvar *next-inst-id* 0) @@ -280,21 +295,6 @@ (clrhash *inst-ids*) (setf *next-inst-id* 0)) - -;;;; Locations, and operations thereon. - -(defun canonicalize-locations (locations) - (let ((results nil)) - (labels ((grovel (location) - (typecase location - (list (dolist (x location) (grovel x))) - (c:tn (push (c:tn-location location) results)) - (number) ; blow off immediates - (t (push location results))))) - (grovel locations)) - results)) - - ;;;; The scheduler itself. @@ -314,76 +314,76 @@ ,@body (setf (segment-run-scheduler ,seg) ,var)))) +(defmacro note-dependencies ((segment inst) &body body) + (ext:once-only ((segment segment) (inst inst)) + `(macrolet ((reads (loc) `(note-read-dependency ,',segment ,',inst ,loc)) + (writes (loc &rest keys) + `(note-write-dependency ,',segment ,',inst ,loc ,@keys))) + ,@body))) + +(defun note-read-dependency (segment inst read) + (let ((index (c:location-number read))) + #+debug (format *trace-output* "~&~S reads ~S[~D]~%" inst read index) + (when index + (let ((writer (svref (segment-writers segment) index))) + (when writer + (let ((prev-inst (car writer))) + (sset-adjoin prev-inst (inst-read-dependencies inst)) + (sset-adjoin inst (inst-read-dependents prev-inst)) + (sset-delete prev-inst (segment-emittable-insts-sset segment))))) + (push inst (svref (segment-readers segment) index)))) + (ext:undefined-value)) + +(defun note-write-dependency (segment inst write &key partially) + (let ((index (c:location-number write))) + #+debug (format *trace-output* "~&~S writes ~S[~D]~%" inst write index) + (when index + ;; All previous reads of this location must have completed. + (dolist (prev-inst (svref (segment-readers segment) index)) + (unless (eq prev-inst inst) + (sset-adjoin prev-inst (inst-write-dependencies inst)) + (sset-adjoin inst (inst-write-dependents prev-inst)) + (sset-delete prev-inst (segment-emittable-insts-sset segment)))) + (when partially + ;; All previous writes to the location must have completed. + (dolist (prev-inst (svref (segment-writers segment) index)) + (sset-adjoin prev-inst (inst-write-dependencies inst)) + (sset-adjoin inst (inst-write-dependents prev-inst)) + (sset-delete prev-inst (segment-emittable-insts-sset segment)))) + (push inst (svref (segment-writers segment) index)))) + (ext:undefined-value)) + ;;; QUEUE-INST -- internal. ;;; ;;; This routine is called by due to uses of the INST macro when the scheduler -;;; is turned on. We compute the change to the dependency graph and check to -;;; see if the basic block is terminated. +;;; is turned on. The change to the dependency graph has already been +;;; computed, so we just have to check to see if the basic block is terminated. ;;; -(defun queue-inst (segment inst reads writes) +(defun queue-inst (segment inst) #+debug (format *trace-output* "~&Queuing ~S~%" inst) (assert (segment-run-scheduler segment)) - (let* ((writers (segment-writers segment)) - (readers (segment-readers segment)) - (read-dependencies nil) - (write-dependencies nil) - (emittable-insts (segment-emittable-insts segment))) - ;; For everything we read, find out who wrote it and note that we - ;; depend on them. - (dolist (read reads) - (let ((writer (assoc read writers :test #'eq))) - (when writer - (let ((prev-inst (cadr writer))) - (pushnew prev-inst read-dependencies) - (pushnew inst (inst-read-dependents prev-inst)) - (setf emittable-insts - (delete prev-inst emittable-insts :test #'eq)))))) - ;; For everything we write, find out who has read the old value and - ;; note that we depend on them also. Also, change the writers record - ;; to indicate that we wrote that location last. - (dolist (write writes) - (let ((reader (assoc write readers :test #'eq))) - (when reader - (dolist (prev-inst (cdr reader)) - (pushnew prev-inst write-dependencies) - (pushnew inst (inst-write-dependents prev-inst)) - (setf emittable-insts - (delete prev-inst emittable-insts :test #'eq))) - (setf readers (delete reader readers :test #'eq)))) - (let ((writer (assoc write writers :test #'eq))) - (if writer - (push inst (cdr writer)) - (push (list write inst) writers)))) - #+debug - (when read-dependencies - (format *trace-output* " Reads values produced by ~:S.~%" - read-dependencies)) - (setf (inst-read-dependencies inst) read-dependencies) - #+debug - (when write-dependencies - (format *trace-output* " Writes values needed by ~:S.~%" - write-dependencies)) - (setf (inst-write-dependencies inst) write-dependencies) - (dolist (read reads) - (let ((reader (assoc read readers :test #'eq))) - (if reader - (pushnew inst (cdr reader)) - (push (list read inst) readers)))) - (setf (segment-readers segment) readers) - (setf (segment-writers segment) writers) - (let ((countdown (segment-branch-countdown segment))) - (cond ((instruction-attributep (inst-attributes inst) branch) - (unless countdown - (setf countdown (inst-delay inst))) - (push (cons countdown inst) - (segment-queued-branches segment))) - (t - (setf emittable-insts (cons inst emittable-insts)))) - (setf (segment-emittable-insts segment) emittable-insts) - (when countdown - (if (minusp (decf countdown)) - (schedule-pending-instructions segment) - (setf (segment-branch-countdown segment) countdown))))) + (let ((countdown (segment-branch-countdown segment))) + (cond ((instruction-attributep (inst-attributes inst) branch) + (unless countdown + (setf countdown (inst-delay inst))) + (push (cons countdown inst) + (segment-queued-branches segment))) + (t + (sset-adjoin inst (segment-emittable-insts-sset segment)))) + (when countdown + (if (minusp (decf countdown)) + (schedule-pending-instructions segment) + (setf (segment-branch-countdown segment) countdown)))) + #+debug + (format *trace-output* " reads ~S~% writes ~S~%" + (ext:collect ((reads)) + (do-elements (read (inst-read-dependencies inst)) + (reads read)) + (reads)) + (ext:collect ((writes)) + (do-elements (write (inst-write-dependencies inst)) + (writes write)) + (writes))) (ext:undefined-value)) ;;; SCHEDULE-PENDING-INSTRUCTIONS -- internal. @@ -398,46 +398,45 @@ (assert (segment-run-scheduler segment)) ;; ;; Quick blow-out if nothing to do. - (unless (or (segment-emittable-insts segment) - (segment-queued-branches segment)) + (when (and (sset-empty (segment-emittable-insts-sset segment)) + (null (segment-queued-branches segment))) (return-from schedule-pending-instructions (ext:undefined-value))) ;; ;; Note that any values live at the end of the block have to be computed ;; last. - (let ((emittable-insts (segment-emittable-insts segment))) - (dolist (writer (segment-writers segment)) - (let ((inst (second writer)) - (overwritten (cddr writer))) - (when overwritten - (let ((write-dependencies (inst-write-dependencies inst))) - (dolist (other-inst (cddr writer)) - (pushnew inst (inst-write-dependents other-inst)) - (pushnew other-inst write-dependencies) - (setf emittable-insts - (delete other-inst emittable-insts :test #'eq))) - (setf (inst-write-dependencies inst) write-dependencies))) - ;; If the value is live at the end of the block, we can't flush it. - (setf (instruction-attributep (inst-attributes inst) flushable) nil))) - (setf (segment-emittable-insts segment) emittable-insts)) + (let ((emittable-insts (segment-emittable-insts-sset segment)) + (writers (segment-writers segment))) + (dotimes (index (length writers)) + (let* ((writer (svref writers index)) + (inst (car writer)) + (overwritten (cdr writer))) + (when writer + (when overwritten + (let ((write-dependencies (inst-write-dependencies inst))) + (dolist (other-inst overwritten) + (sset-adjoin inst (inst-write-dependents other-inst)) + (sset-adjoin other-inst write-dependencies) + (sset-delete other-inst emittable-insts)))) + ;; If the value is live at the end of the block, we can't flush it. + (setf (instruction-attributep (inst-attributes inst) flushable) + nil))))) ;; ;; Grovel through the entire graph in the forward direction finding all ;; the leaf instructions. (labels ((grovel-inst (inst) - (let ((write-deps (inst-write-dependencies inst)) - (read-deps (inst-read-dependencies inst)) - (max 0)) - (dolist (dep write-deps) + (let ((max 0)) + (do-elements (dep (inst-write-dependencies inst)) (let ((dep-depth (or (inst-depth dep) (grovel-inst dep)))) (when (> dep-depth max) (setf max dep-depth)))) - (dolist (dep read-deps) + (do-elements (dep (inst-read-dependencies inst)) (let ((dep-depth (+ (or (inst-depth dep) (grovel-inst dep)) (inst-delay dep)))) (when (> dep-depth max) (setf max dep-depth)))) - (cond ((and (null (inst-read-dependents inst)) + (cond ((and (sset-empty (inst-read-dependents inst)) (instruction-attributep (inst-attributes inst) flushable)) #+debug @@ -445,17 +444,17 @@ (setf (inst-emitter inst) nil) (setf (inst-depth inst) max)) (t - (setf (inst-depth inst) #+nil (1+ max) max)))))) - (let ((really-emittable-insts nil) + (setf (inst-depth inst) max)))))) + (let ((emittable-insts nil) (delayed nil)) - (dolist (inst (segment-emittable-insts segment)) + (do-elements (inst (segment-emittable-insts-sset segment)) (grovel-inst inst) (if (zerop (inst-delay inst)) - (push inst really-emittable-insts) + (push inst emittable-insts) (setf delayed (add-to-nth-list delayed inst (1- (inst-delay inst)))))) - (setf (segment-emittable-insts segment) - (sort really-emittable-insts #'> :key #'inst-depth)) + (setf (segment-emittable-insts-queue segment) + (sort emittable-insts #'> :key #'inst-depth)) (setf (segment-delayed segment) delayed)) (dolist (branch (segment-queued-branches segment)) (grovel-inst (cdr branch)))) @@ -464,7 +463,7 @@ (segment-queued-branches segment)) #+debug (format *trace-output* "Initially emittable: ~S~%" - (segment-emittable-insts segment)) + (segment-emittable-insts-queue segment)) #+debug (format *trace-output* "Initially delayed: ~S~%" (segment-delayed segment)) @@ -482,12 +481,13 @@ #+debug (format *trace-output* "Filling branch delay slot...~%") (flet ((maybe-schedule-dependent (dependents) - (when dependents - (let ((inst (car dependents))) - (note-resolved-dependencies segment inst) - (setf (segment-emittable-insts segment) - (delete inst (segment-emittable-insts segment))) - inst)))) + (do-elements (inst dependents) + (note-resolved-dependencies segment inst) + (setf (segment-emittable-insts-queue segment) + (delete inst + (segment-emittable-insts-queue segment) + :test #'eq)) + (return inst)))) (push (or (maybe-schedule-dependent (inst-read-dependents inst)) (maybe-schedule-dependent (inst-write-dependents inst)) (schedule-one-inst segment) @@ -518,10 +518,12 @@ (setf (segment-run-scheduler segment) t)) ;; ;; Clear out any residue left over. + (setf (segment-inst-number segment) 0) (setf (segment-queued-branches segment) nil) (setf (segment-branch-countdown segment) nil) - (setf (segment-readers segment) nil) - (setf (segment-writers segment) nil) + (setf (segment-emittable-insts-sset segment) (make-sset)) + (fill (segment-readers segment) nil) + (fill (segment-writers segment) nil) ;; ;; That's all folks. (ext:undefined-value)) @@ -548,7 +550,7 @@ ;;; a nop must be emitted. If we are all done, return NIL. ;;; (defun schedule-one-inst (segment) - (let ((inst (pop (segment-emittable-insts segment)))) + (let ((inst (pop (segment-emittable-insts-queue segment)))) (cond (inst ;; We've got us a live one here. Go for it. #+debug @@ -578,28 +580,26 @@ ;;; dependency can be emitted now. ;;; (defun note-resolved-dependencies (segment inst) - (assert (null (inst-read-dependents inst))) - (assert (null (inst-write-dependents inst))) - (dolist (dep (inst-write-dependencies inst)) + (assert (sset-empty (inst-read-dependents inst))) + (assert (sset-empty (inst-write-dependents inst))) + (do-elements (dep (inst-write-dependencies inst)) ;; These are the instructions who have to be completed before our ;; write fires. Doesn't matter how far before, just before. (let ((dependents (inst-write-dependents dep))) - (setf dependents (delete inst dependents :test #'eq)) - (setf (inst-write-dependents dep) dependents) - (when (and (null dependents) - (null (inst-read-dependents dep))) + (sset-delete inst dependents) + (when (and (sset-empty dependents) + (sset-empty (inst-read-dependents dep))) (insert-emittable-inst segment dep)))) - (dolist (dep (inst-read-dependencies inst)) + (do-elements (dep (inst-read-dependencies inst)) ;; These are the instructions who write values we read. If there ;; is no delay, then just remove us from the dependent list. ;; Otherwise, record the fact that in n cycles, we should be ;; removed. (if (zerop (inst-delay dep)) (let ((dependents (inst-read-dependents dep))) - (setf dependents (delete inst dependents :test #'eq)) - (setf (inst-read-dependents dep) dependents) - (when (and (null dependents) - (null (inst-write-dependents dep))) + (sset-delete inst dependents) + (when (and (sset-empty dependents) + (sset-empty (inst-write-dependents dep))) (insert-emittable-inst segment dep))) (setf (segment-delayed segment) (add-to-nth-list (segment-delayed segment) @@ -619,17 +619,16 @@ (let* ((dependency (car stuff)) (dependent (cdr stuff)) (dependents (inst-read-dependents dependency))) - (setf dependents (delete dependent dependents :test #'eq)) - (setf (inst-read-dependents dependency) dependents) - (when (and (null dependents) - (null (inst-write-dependents dependency))) + (sset-delete dependent dependents) + (when (and (sset-empty dependents) + (sset-empty (inst-write-dependents dependency))) (insert-emittable-inst segment dependency))) (insert-emittable-inst segment stuff))))) ;;; INSERT-EMITTABLE-INST -- internal. ;;; -;;; Note that inst is emittable by sticking it in the SEGMENT-EMITTABLE-INSTS -;;; list. We keep the emittable-insts sorted with the largest ``depths'' +;;; Note that inst is emittable by sticking it in the SEGMENT-EMITTABLE-INSTS- +;;; QUEUE list. We keep the emittable-insts sorted with the largest ``depths'' ;;; first. Except that if INST is a branch, don't bother. It will be handled ;;; correctly by the branch emitting code in SCHEDULE-PENDING-INSTRUCTIONS. ;;; @@ -638,12 +637,13 @@ #+debug (format *Trace-output* "Now emittable: ~S~%" inst) (do ((my-depth (inst-depth inst)) - (remaining (segment-emittable-insts segment) (cdr remaining)) + (remaining (segment-emittable-insts-queue segment) (cdr remaining)) (prev nil remaining)) ((or (null remaining) (> my-depth (inst-depth (car remaining)))) (if prev (setf (cdr prev) (cons inst remaining)) - (setf (segment-emittable-insts segment) (cons inst remaining)))))) + (setf (segment-emittable-insts-queue segment) + (cons inst remaining)))))) (ext:undefined-value)) @@ -1596,8 +1596,7 @@ (emitter nil) (decls nil) (attributes nil) - (reads nil) - (writes nil) + (dependencies nil) (delay nil) (pinned nil) (pdefs nil) @@ -1618,29 +1617,15 @@ (setf decls (append decls args))) (:attributes (setf attributes (append attributes args))) - (:reads - (cond ((not scheduler-p) - (warn "Ignoring :READS because scheduler turned off.")) - ((or reads (cdr args)) - (error - "Can only specify one reads expression per instruction.")) - (t - (setf reads (car args))))) - (:writes - (cond ((not scheduler-p) - (warn "Ignoring :WRITES because scheduler turned off.")) - ((or writes (cdr args)) - (error - "Can only specify one writes expression per instruction.")) - (t - (setf writes (car args))))) + (:dependencies + (setf dependencies (append dependencies args))) (:delay - (cond ((not scheduler-p) - (warn "Ignoring :DELAY because scheduler turned off.")) - (delay - (error "Can only specify delay once per instruction.")) - (t - (setf delay args)))) + (when delay + (error "Can only specify delay once per instruction.")) + (setf delay args)) + ((:reads :writes) + ;; ### Ignore them for now. + nil) (:pinned (setf pinned t)) (:vop-var @@ -1688,20 +1673,24 @@ (schedule-pending-instructions ,segment-name)) ,@emitter)) (let ((flet-name - (gensym (concatenate 'string "EMIT-" sym-name "-INST-")))) + (gensym (concatenate 'string "EMIT-" sym-name "-INST-"))) + (inst-name (gensym "INST-"))) (setf emitter `((flet ((,flet-name (,segment-name) ,@emitter)) (if (segment-run-scheduler ,segment-name) - (queue-inst ,segment-name - (make-instruction - #',flet-name - (instruction-attributes - ,@attributes) - (progn ,@delay)) - (canonicalize-locations - ,reads) - (canonicalize-locations - ,writes)) + (let ((,inst-name + (make-instruction + (incf (segment-inst-number + ,segment-name)) + #',flet-name + (instruction-attributes + ,@attributes) + (progn ,@delay)))) + ,@(when dependencies + `((note-dependencies + (,segment-name ,inst-name) + ,@dependencies))) + (queue-inst ,segment-name ,inst-name)) (,flet-name ,segment-name)))))))) `(progn (defun ,defun-name ,new-lambda-list -- GitLab