diff --git a/BIR-transformations/meta-evaluate.lisp b/BIR-transformations/meta-evaluate.lisp index 24a11d62..be43a1ae 100644 --- a/BIR-transformations/meta-evaluate.lisp +++ b/BIR-transformations/meta-evaluate.lisp @@ -6,23 +6,73 @@ (in-package #:cleavir-bir-transformations) +;; 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)) + (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. - (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 *changed-anything-on-last-pass* + ;; Make sure we stop looping if we don't derive any types in the + ;; 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? + (when (set:presentp function (bir:functions module)) + (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)) + +;;; 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) - (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 + (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 *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)) + ;;; 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) @@ -199,8 +249,16 @@ ;; 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) + ;; 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)) @@ -453,7 +511,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 @@ -462,6 +520,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))) @@ -551,25 +613,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, @@ -667,11 +742,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) @@ -691,17 +774,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)) @@ -724,10 +815,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 @@ -932,12 +1027,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) @@ -1173,11 +1273,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)) @@ -1188,10 +1293,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) @@ -1203,10 +1313,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) @@ -1221,14 +1335,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. @@ -1244,10 +1363,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)) @@ -1259,10 +1383,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) 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)