From a04b8ebec2ce9a8926a536c7f1dd05053b638c76 Mon Sep 17 00:00:00 2001 From: Tycho Bear Date: Thu, 13 Jun 2024 17:10:02 -0400 Subject: [PATCH 1/4] Updated meta-evaluate.lisp to run to a fixed point instead of making a constant number of passes. --- BIR-transformations/meta-evaluate.lisp | 32 ++++++++++++++++++-------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/BIR-transformations/meta-evaluate.lisp b/BIR-transformations/meta-evaluate.lisp index 24a11d62..c4bf4ded 100644 --- a/BIR-transformations/meta-evaluate.lisp +++ b/BIR-transformations/meta-evaluate.lisp @@ -6,23 +6,35 @@ (in-package #:cleavir-bir-transformations) +;; This keeps track of whether any types were derived on the previous pass. We +;; want to keep making passes until we reach a fixed point, or in other words, +;; have derived all the types we possibly can. +(defparameter *derived-anything-on-last-pass* T) + (defun meta-evaluate-module (module system) ;; Obviously this should actually be a worklist algorithm and not ;; just two or three passes. We repeat on the module level so that ;; types are more likely to get propagated interprocedurally. - (dotimes (repeat 3) - (declare (ignorable repeat)) - (bir:do-functions (function module) - ;; This check is necessary because meta-evaluation might have deleted - ;; the function during our iteration. KLUDGE? - (when (set:presentp function (bir:functions module)) - (meta-evaluate-function function system) - (bir:compute-iblock-flow-order function))))) + (loop while *derived-anything-on-last-pass* + ;; Make sure we stop looping if we don't derive any types in the + ;; current iteration + do (setq *derived-anything-on-last-pass* NIL) + (bir:do-functions (function module) + ;; This check is necessary because meta-evaluation might have deleted + ;; the function during our iteration. KLUDGE? + (when (set:presentp function (bir:functions module)) + (meta-evaluate-function function system) + (bir:compute-iblock-flow-order function))))) ;;; Prove that LINEAR-DATUM is of type DERIVED-TYPE. (defun derive-type-for-linear-datum (linear-datum derived-type system) - (setf (bir:derived-type linear-datum) - (ctype:values-conjoin system (bir:ctype linear-datum) derived-type))) + (let ((old-type (bir:ctype linear-datum))) + (setf (bir:derived-type linear-datum) + (ctype:values-conjoin system (bir:ctype linear-datum) derived-type)) + ;; If we derive a type in the current pass + (if (not (equal old-type (bir:ctype linear-datum))) + (setq *derived-anything-on-last-pass* T)))) + ;;; Pass along an assertion that LINEAR-DATUM is of type ASSERTED-TYPE. (defun assert-type-for-linear-datum (linear-datum asserted-type system) (setf (bir:asserted-type linear-datum) From 0d7eb7fd61b1ce3257b3ad2924587590ab781350 Mon Sep 17 00:00:00 2001 From: Tycho Bear Date: Mon, 15 Jul 2024 18:13:13 -0400 Subject: [PATCH 2/4] Quickly adding flags here so I can build clasp --- BIR/structure.lisp | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/BIR/structure.lisp b/BIR/structure.lisp index 56e09f0a..157ec176 100644 --- a/BIR/structure.lisp +++ b/BIR/structure.lisp @@ -186,7 +186,12 @@ See REPLACE-USES")) (%iblock :initarg :iblock :accessor iblock :type iblock :documentation "The IBLOCK this instruction belongs to.") (%policy :initform (current-policy) :initarg :policy :reader policy) - (%origin :initform (current-origin) :initarg :origin :reader origin)) + (%origin :initform (current-origin) :initarg :origin :reader origin) + (%should-process :initform T + :initarg :should-process + :accessor :should-process + :type boolean + :documentation "Determines whether to process this instruction on the next pass during meta-evaluation.")) (:documentation "Abstract. Cleavir's representation of a computation to be done. All instructions have a sequence of input data and a sequence of output data. With a few exceptions, documented in individual instruction classes, all inputs and outputs are linear. @@ -419,7 +424,12 @@ It can be read from and written to any number of times, and across FUNCTIONs, bu ;; The function this belongs to. (%function :initarg :function :accessor function :type (or null function)) ; null is for deleted blocks ;; For debug/introspection - (%name :initarg :name :reader name :initform nil)) + (%name :initarg :name :reader name :initform nil) + (%should-process :initform T + :initarg :should-process + :accessor :should-process + :type boolean + :documentation "Determines whether to process this iblock on the next pass during meta-evaluation.")) (:documentation "A sequence of instructions with no branching. In other words this is a conventional \"basic block\", except that Cleavir will sometimes keep distinct iblock segments around for various purposes, such as to indicate differnet dynamic environments.")) @@ -484,7 +494,12 @@ In other words this is a conventional \"basic block\", except that Cleavir will (%attributes :initarg :attributes :accessor attributes :initform (attributes:default-attributes)) ;; The module containing this function. - (%module :initarg :module :reader module :type module)) + (%module :initarg :module :reader module :type module) + (%should-process :initform T + :initarg :should-process + :accessor :should-process + :type boolean + :documentation "Determines whether to process this function on the next pass during meta-evaluation.")) (:documentation "Cleavir's representation of the code for a Lisp function.")) (defmethod print-object ((o function) s) From 439053ea15d2559c71ce2355ffa095907d1df49f Mon Sep 17 00:00:00 2001 From: Tycho Bear Date: Mon, 29 Jul 2024 14:49:16 -0400 Subject: [PATCH 3/4] Updated meta-evaluate.lisp to flag and unflag instructions based on type derivation. Additionally, updated its meta-evaluate-iblock function to only process flagged instructions. --- BIR-transformations/meta-evaluate.lisp | 166 ++++++++++++++++++++----- 1 file changed, 133 insertions(+), 33 deletions(-) diff --git a/BIR-transformations/meta-evaluate.lisp b/BIR-transformations/meta-evaluate.lisp index c4bf4ded..37e730f9 100644 --- a/BIR-transformations/meta-evaluate.lisp +++ b/BIR-transformations/meta-evaluate.lisp @@ -11,7 +11,19 @@ ;; have derived all the types we possibly can. (defparameter *derived-anything-on-last-pass* T) +;; Simple flag to indicate whether we're on the first pass of meta-evaluation. +(defparameter *is-first-pass* T) + (defun meta-evaluate-module (module system) + + ;; First pass to establish a baseline for type derivation + (bir:do-functions (function module) + (when (set:presentp function (bir:functions module)) + (meta-evaluate-function function system) + (bir:compute-iblock-flow-order function))) + + (setq *is-first-pass* NIL) + ;; Obviously this should actually be a worklist algorithm and not ;; just two or three passes. We repeat on the module level so that ;; types are more likely to get propagated interprocedurally. @@ -26,14 +38,30 @@ (meta-evaluate-function function system) (bir:compute-iblock-flow-order function))))) + +;;; Given a linear datum, flag the instruction where it's used, along with the +;;; iblock and function containing the instruction. +(defun flag-datum-use (linear-datum) + ;; flag the instruction using this datum for reprocessing + (setf (:should-process (bir:use linear-datum)) T) + ;; flag the instruction's iblock + (setf (:should-process (bir:iblock (bir:use linear-datum))) T) + ;; flag the iblock's function + (setf (:should-process (bir:function (bir:iblock (bir:use linear-datum)))) T)) + ;;; Prove that LINEAR-DATUM is of type DERIVED-TYPE. +;;; Returns T if a type was derived, and NIL otherwise. (defun derive-type-for-linear-datum (linear-datum derived-type system) (let ((old-type (bir:ctype linear-datum))) (setf (bir:derived-type linear-datum) (ctype:values-conjoin system (bir:ctype linear-datum) derived-type)) + ;; If we derive a type in the current pass - (if (not (equal old-type (bir:ctype linear-datum))) - (setq *derived-anything-on-last-pass* T)))) + (when (and (not (equal old-type (bir:ctype linear-datum))) (cleavir-ctype:subtypep (bir:ctype linear-datum) old-type system) (bir:use linear-datum)) + (setq *derived-anything-on-last-pass* T) + (flag-datum-use linear-datum) + (return-from derive-type-for-linear-datum T))) + (return-from derive-type-for-linear-datum NIL)) ;;; Pass along an assertion that LINEAR-DATUM is of type ASSERTED-TYPE. (defun assert-type-for-linear-datum (linear-datum asserted-type system) @@ -211,8 +239,9 @@ ;; of whether a rewrite is on the way, and if we do things in this order we ;; can derive types through any amount of straight line code during a single ;; meta-evaluate pass, promoting flow. - (derive-types instruction system) - (meta-evaluate-instruction instruction system))) + (when (:should-process instruction) + (derive-types instruction system) + (meta-evaluate-instruction instruction system)))) (defgeneric maybe-flush-instruction (instruction system)) @@ -465,7 +494,7 @@ (ctype:bottom system) system) system) - (derive-type-for-linear-datum + (let ((derived-a-type (derive-type-for-linear-datum (bir:output instruction) (ctype:values (loop for inp in inputs @@ -474,6 +503,10 @@ (ctype:bottom system) system) system))) + ;; If we didn't derive a type for this datum, and we've analyzed the + ;; instruction before, then we can ignore it for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process instruction) NIL))))) (defmethod meta-evaluate-instruction ((instruction bir:eq-test) system) (let ((inputs (bir:inputs instruction))) @@ -563,25 +596,38 @@ t))))) (defmethod derive-types ((instruction bir:constant-reference) system) - (derive-type-for-linear-datum + (let ((derived-a-type (derive-type-for-linear-datum (bir:output instruction) (ctype:single-value (ctype:member system (bir:constant-value (bir:input instruction))) system) - system)) + system))) + ;; If we didn't derive a type for this datum, and we've analyzed the + ;; instruction before, then we can ignore it for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process instruction) NIL)))) (defmethod derive-types ((instruction bir:constant-fdefinition) system) ;; Derive that it's a FUNCTION. - (derive-type-for-linear-datum + (let ((derived-a-type (derive-type-for-linear-datum (bir:output instruction) (ctype:single-value (ctype:function-top system) system) - system)) + system))) + ;; If we didn't derive a type for this datum, and we've analyzed the + ;; instruction before, then we can ignore it for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process instruction) NIL)))) + (defmethod derive-types ((instruction bir:constant-symbol-value) system) - (derive-type-for-linear-datum + (let ((derived-a-type (derive-type-for-linear-datum (bir:output instruction) (ctype:single-value (ctype:top system) system) - system)) + system))) + ;; If we didn't derive a type for this datum, and we've analyzed the + ;; instruction before, then we can ignore it for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process instruction) NIL)))) ;;; Local variable with one reader and one writer can be substituted ;;; away, @@ -679,11 +725,19 @@ (set:doset (local-call (bir:local-calls function)) (let ((out (bir:output local-call))) (assert-type-for-linear-datum out areturn-type system) - (derive-type-for-linear-datum out return-type system))))) + (let ((derived-a-type (derive-type-for-linear-datum out return-type system))) + ;; If we didn't derive a type for this datum, and we've analyzed the + ;; instruction before, then we can ignore it for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process instruction) NIL))))))) (defmethod derive-types ((instruction bir:enclose) system) (let ((ftype (ctype:single-value (ctype:function-top system) system))) - (derive-type-for-linear-datum (bir:output instruction) ftype system))) + (let ((derived-a-type (derive-type-for-linear-datum (bir:output instruction) ftype system))) + ;; If we didn't derive a type for this datum, and we've analyzed the + ;; instruction before, then we can ignore it for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process instruction) NIL))))) ;;; If the number of values to be saved is known, record that. (defmethod meta-evaluate-instruction ((instruction bir:values-save) system) @@ -703,17 +757,25 @@ (assert-type-for-linear-datum (bir:output instruction) (bir:asserted-type (bir:input instruction)) system) - (derive-type-for-linear-datum (bir:output instruction) + (let ((derived-a-type (derive-type-for-linear-datum (bir:output instruction) (bir:ctype (bir:input instruction)) - system)) + system))) + ;; If we didn't derive a type for this datum, and we've analyzed the + ;; instruction before, then we can ignore it for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process instruction) NIL)))) (defmethod derive-types ((instruction bir:values-restore) system) (assert-type-for-linear-datum (bir:output instruction) (bir:asserted-type (bir:input instruction)) system) - (derive-type-for-linear-datum (bir:output instruction) + (let ((derived-a-type (derive-type-for-linear-datum (bir:output instruction) (bir:ctype (bir:input instruction)) - system)) + system))) + ;; If we didn't derive a type for this datum, and we've analyzed the + ;; instruction before, then we can ignore it for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process instruction) NIL)))) (defun append-input-types (types system) (apply #'ctype:values-append system types)) @@ -736,10 +798,14 @@ (bir:output instruction) (append-input-types (mapcar #'bir:asserted-type inputs) system) system) - (derive-type-for-linear-datum + (let ((derived-a-type (derive-type-for-linear-datum (bir:output instruction) (append-input-types (mapcar #'bir:ctype inputs) system) system))) + ;; If we didn't derive a type for this datum, and we've analyzed the + ;; instruction before, then we can ignore it for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process instruction) NIL))))) ;;; Move a thei to earlier in the code. ;;; It is not clear if this is permissible in general; while the behavior @@ -944,12 +1010,17 @@ ;; freedom to trust or explicitly check the assertion as needed while ;; making this decision transparent to inference, and also type conflict ;; when the type is checked elsewhere. - (derive-type-for-linear-datum + (let ((derived-a-type (derive-type-for-linear-datum (bir:output instruction) (if (eq type-check-function nil) ctype (ctype:values-conjoin system (bir:asserted-type instruction) ctype)) - system) + system))) + ;; If we didn't derive a type for this datum, and we've analyzed the + ;; instruction before, then we can ignore it for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process instruction) NIL))) + ;; The asserted type can be propagated even if it's not checked. (assert-type-for-linear-datum (bir:output instruction) @@ -1185,11 +1256,16 @@ (derive-return-type inst identity intype system))) (cond ((null identities)) ((= (length identities) 1) - (derive-type-for-linear-datum + (let ((derived-a-type (derive-type-for-linear-datum (bir:output inst) (compute (first identities) (intype #'bir:ctype)) - system) - (assert-type-for-linear-datum + system))) + ;; If we didn't derive a type for this datum, and we've + ;; analyzed the instruction before, then we can ignore it + ;; for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process inst) NIL))) + (assert-type-for-linear-datum (bir:output inst) (compute (first identities) (intype #'bir:asserted-type)) system)) @@ -1200,10 +1276,15 @@ (atypes (loop for identity in identities collect (compute identity (intype #'bir:asserted-type))))) - (derive-type-for-linear-datum (bir:output inst) + (let ((derived-a-type (derive-type-for-linear-datum (bir:output inst) (apply #'ctype:values-conjoin system dtypes) - system) + system))) + ;; If we didn't derive a type for this datum, and we've + ;; analyzed the instruction before, then we can ignore it + ;; for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process inst) NIL))) (assert-type-for-linear-datum (bir:output inst) (apply #'ctype:values-conjoin system atypes) @@ -1215,10 +1296,14 @@ (append-input-types (mapcar reader (rest (bir:inputs inst))) system))) (cond ((null identities)) ((= (length identities) 1) - (derive-type-for-linear-datum + (let ((derived-a-type (derive-type-for-linear-datum (bir:output inst) (derive-return-type inst (first identities) (intype #'bir:ctype) system) - system) + system))) + ;; If we didn't derive a type for this datum, and we've analyzed + ;; the instruction before, then we can ignore it for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process inst) NIL))) (assert-type-for-linear-datum (bir:output inst) (derive-return-type inst (first identities) (intype #'bir:asserted-type) @@ -1233,14 +1318,19 @@ (loop with arg = (intype #'bir:asserted-type) for identity in identities collect (derive-return-type inst identity arg system)))) - (derive-type-for-linear-datum (bir:output inst) + (let ((derived-a-type (or (derive-type-for-linear-datum (bir:output inst) (apply #'ctype:values-conjoin system dtypes) system) (derive-type-for-linear-datum (bir:output inst) (apply #'ctype:values-conjoin system atypes) - system))))))) + system)))) + ;; If we didn't derive a type for this datum, and we've + ;; analyzed the instruction before, then we can ignore it + ;; for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process inst) NIL))))))))) (defmethod derive-types ((inst bir:primop) system) ;; Only do this when there's exactly one output. @@ -1256,10 +1346,15 @@ (derive-return-type inst identity intype system))) (cond ((null identities)) ((= (length identities) 1) - (derive-type-for-linear-datum + (let ((derived-a-type (derive-type-for-linear-datum (bir:output inst) (compute (first identities) (intype #'bir:ctype)) - system) + system))) + ;; If we didn't derive a type for this datum, and we've + ;; analyzed the instruction before, then we can ignore it + ;; for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process inst) NIL))) (assert-type-for-linear-datum (bir:output inst) (compute (first identities) (intype #'bir:asserted-type)) @@ -1271,10 +1366,15 @@ (atypes (loop for identity in identities collect (compute identity (intype #'bir:asserted-type))))) - (derive-type-for-linear-datum (bir:output inst) + (let ((derived-a-type (derive-type-for-linear-datum (bir:output inst) (apply #'ctype:values-conjoin system dtypes) - system) + system))) + ;; If we didn't derive a type for this datum, and we've + ;; analyzed the instruction before, then we can ignore it + ;; for now. + (when (and (not derived-a-type) (not *is-first-pass*)) + (setf (:should-process inst) NIL))) (assert-type-for-linear-datum (bir:output inst) (apply #'ctype:values-conjoin system atypes) From 6ff382a38eaab45672e28bd208fd44e6027adf67 Mon Sep 17 00:00:00 2001 From: Tycho Bear Date: Tue, 6 Aug 2024 13:35:16 -0400 Subject: [PATCH 4/4] Committing to save progress. Working on tracking additional changes that arise from evaluating meta-evaluate-instruction. --- BIR-transformations/meta-evaluate.lisp | 37 +++++++++++++++++++------- 1 file changed, 27 insertions(+), 10 deletions(-) diff --git a/BIR-transformations/meta-evaluate.lisp b/BIR-transformations/meta-evaluate.lisp index 37e730f9..be43a1ae 100644 --- a/BIR-transformations/meta-evaluate.lisp +++ b/BIR-transformations/meta-evaluate.lisp @@ -6,16 +6,15 @@ (in-package #:cleavir-bir-transformations) -;; This keeps track of whether any types were derived on the previous pass. We -;; want to keep making passes until we reach a fixed point, or in other words, -;; have derived all the types we possibly can. -(defparameter *derived-anything-on-last-pass* T) +;; This keeps track of whether any types were derived on the previous pass, or +;; the code was changed in some manner. We want to keep making passes until we +;; reach a fixed point, and have derived all the types we possibly can. +(defparameter *changed-anything-on-last-pass* T) ;; Simple flag to indicate whether we're on the first pass of meta-evaluation. (defparameter *is-first-pass* T) (defun meta-evaluate-module (module system) - ;; First pass to establish a baseline for type derivation (bir:do-functions (function module) (when (set:presentp function (bir:functions module)) @@ -27,10 +26,14 @@ ;; Obviously this should actually be a worklist algorithm and not ;; just two or three passes. We repeat on the module level so that ;; types are more likely to get propagated interprocedurally. - (loop while *derived-anything-on-last-pass* + (loop while *changed-anything-on-last-pass* ;; Make sure we stop looping if we don't derive any types in the - ;; current iteration - do (setq *derived-anything-on-last-pass* NIL) + ;; current iteration + do (setq *changed-anything-on-last-pass* NIL) + + ;; debug + (format t "in main loop, about to evaluate the functions~%") + (bir:do-functions (function module) ;; This check is necessary because meta-evaluation might have deleted ;; the function during our iteration. KLUDGE? @@ -49,6 +52,12 @@ ;; flag the iblock's function (setf (:should-process (bir:function (bir:iblock (bir:use linear-datum)))) T)) +;;; Given an iblock, flag all of its instructions for reprocessing. +(defun flag-instructions-in-iblock (iblock) + (bir:do-iblock-instructions (instruction iblock) + (setf (:should-process instruction) T))) + + ;;; Prove that LINEAR-DATUM is of type DERIVED-TYPE. ;;; Returns T if a type was derived, and NIL otherwise. (defun derive-type-for-linear-datum (linear-datum derived-type system) @@ -58,8 +67,9 @@ ;; If we derive a type in the current pass (when (and (not (equal old-type (bir:ctype linear-datum))) (cleavir-ctype:subtypep (bir:ctype linear-datum) old-type system) (bir:use linear-datum)) - (setq *derived-anything-on-last-pass* T) + (setq *changed-anything-on-last-pass* T) (flag-datum-use linear-datum) +;; (format t "derived a type for this datum!~%") (return-from derive-type-for-linear-datum T))) (return-from derive-type-for-linear-datum NIL)) @@ -241,7 +251,14 @@ ;; meta-evaluate pass, promoting flow. (when (:should-process instruction) (derive-types instruction system) - (meta-evaluate-instruction instruction system)))) + ;; Since meta-evaluate-instruction can transform the code, we need to + ;; make sure that we process any new code that might appear. + (when (meta-evaluate-instruction instruction system) + (setq *changed-anything-on-last-pass* T) + ;; debug +;; (format t "Just set *changed-anything-on-last-pass* to T~%") +;; (flag-instructions-in-iblock iblock) + )))) (defgeneric maybe-flush-instruction (instruction system))