Skip to content

meta-evaluate now runs to a fixed point #32

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
tycho-bear wants to merge 4 commits into
base: main
Choose a base branch
from
Open

meta-evaluate now runs to a fixed point #32

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
a04b8eb
Updated meta-evaluate.lisp to run to a fixed point instead of making …
Jun 13, 2024
0d7eb7f
Quickly adding flags here so I can build clasp
Jul 15, 2024
439053e
Updated meta-evaluate.lisp to flag and unflag instructions based on t…
Jul 29, 2024
6ff382a
Committing to save progress. Working on tracking additional changes t…
Aug 6, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
211 changes: 170 additions & 41 deletions BIR-transformations/meta-evaluate.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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))

Expand Down Expand Up @@ -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
Expand All @@ -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)))
Expand Down Expand Up @@ -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,
Expand Down Expand Up @@ -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)
Expand All @@ -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))
Expand All @@ -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
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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))
Expand All @@ -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)
Expand All @@ -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)
Expand All @@ -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.
Expand All @@ -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))
Expand All @@ -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)
Expand Down
Loading