From 6328e883204457bdd5c6b1072c169ff72645ab1e Mon Sep 17 00:00:00 2001 From: "O'Keefe, Colin B" Date: Thu, 18 Jan 2024 09:37:51 -0800 Subject: [PATCH 1/2] CFG path contraction condition was removing entry blocks Fixed bug in cfg path contraction - removed superfluous check on number of children of a block's parents - a labelled block should only be merged with its solitary parent when that parent's outgoing edge is unconditional --- src/cfg.lisp | 57 +++++++++++++++++++++++++++++++++------------------- 1 file changed, 36 insertions(+), 21 deletions(-) diff --git a/src/cfg.lisp b/src/cfg.lisp index ab777e03a..7b5f3888a 100644 --- a/src/cfg.lisp +++ b/src/cfg.lisp @@ -226,7 +226,7 @@ Return the following values: ;; is the current block non-empty? (unless (zerop (length (basic-block-code blk))) ;; build a new block with an unconditional edge coming from the old one - (let ((new-blk (find-or-make-block-from-label cfg (label (princ-to-string (gensym "RESET-")))))) + (let ((new-blk (make-instance 'basic-block :name (gensym "RESET-")))) (link-blocks blk (unconditional-edge new-blk)) (setf blk new-blk))) @@ -415,9 +415,15 @@ Return the following values: (let ((blk (pop dirty))) (when (= 1 (num-edges-in blk)) (let ((parent (first (parents-without-self blk)))) - ;; Check each merging condition until one has been reached, which then applies a specific operation to merge the blocks. + ;; Check each merging condition until one has been + ;; reached, which then applies a specific operation to + ;; merge the blocks. (cond - ;; Condition 1) Extended self-loops can be merged into smaller self loops if there is only 1 edge incoming (excluding self loops, 1 child, if the child is the same block as the parent, and if there is no code within the block + ;; Condition 1) Extended self-loops can be merged into + ;; smaller self loops if there is only 1 edge incoming + ;; (excluding self loops, 1 child, if the child is the + ;; same block as the parent, and if there is no code + ;; within the block ((and (= 1 (length (children blk))) (eq parent (first (children blk))) @@ -453,27 +459,36 @@ Return the following values: ;; Add the parent to the node list (add-dirty-block parent)) - ;; Condition 2) Paths can be contracted when a block has one parent, that parent has one outgoing edge, and neither are the exit or entry block. There is - ;; also the extra condition that and edge cannot be contracted if doing so would cause previously isolated code to be possibly run within a loop. - ((and (or (empty-block-p blk) - (not (> (length (children parent)) 1))) - (or (empty-block-p parent) - (not (find blk (incoming blk)))) - (= 1 (length (children parent))) - (or (and (typep parent 'preserved-block) - (typep blk 'preserved-block)) - (and (not (typep parent 'preserved-block)) - (not (typep blk 'preserved-block)))) - (or (typep blk 'reset-block) - (not (basic-block-out-rewiring parent)) - (not (basic-block-in-rewiring blk)) - (equalp (basic-block-out-rewiring parent) - (basic-block-in-rewiring blk)))) - + ;; Condition 2) Paths can be contracted when a block + ;; has one parent, that parent has one outgoing edge, + ;; and neither are the exit or entry block. There is + ;; also the extra condition that and edge cannot be + ;; contracted if doing so would cause previously + ;; isolated code to be possibly run within a loop. + ((and + (or (empty-block-p parent) + (not (find blk (incoming blk)))) + (= 1 (length (children parent))) + (or (not (labeled blk)) + (and (= 1 (length (incoming blk))) + (adt:match outgoing-edge (outgoing parent) + (unconditional-edge t) + (_ nil)))) + (or (and (typep parent 'preserved-block) + (typep blk 'preserved-block)) + (and (not (typep parent 'preserved-block)) + (not (typep blk 'preserved-block)))) + (or (typep blk 'reset-block) + (not (basic-block-out-rewiring parent)) + (not (basic-block-in-rewiring blk)) + (equalp (basic-block-out-rewiring parent) + (basic-block-in-rewiring blk)))) + ;; The conditions are met to sequentially merge these blocks (let ((new-blk (merge-sequentially parent blk))) ;; After getting a merged block, update the CFG ;; Update the references of affected blocks within the cfg + (dolist (child (children new-blk)) (setf (incoming child) (substitute new-blk blk (incoming child)))) @@ -581,7 +596,7 @@ Return the following values: (let* ((code (parsed-program-executable-code pp)) (entry (make-instance 'basic-block :name (gensym "ENTRY-BLK-") :outgoing terminating-edge)) (cfg (make-instance 'cfg :entry-point entry - :blocks (list entry)))) + :blocks (list entry)))) (flet ((next (current-block) (or current-block (make-instance 'basic-block)))) (loop :with finished-block := nil From 2ea7e7063a40492caa39f3441e33f573cf6515e5 Mon Sep 17 00:00:00 2001 From: "O'Keefe, Colin B" Date: Mon, 22 Jan 2024 07:49:52 -0800 Subject: [PATCH 2/2] Test path contraction doesn't drop valid labeled blocks --- tests/cfg-tests.lisp | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/tests/cfg-tests.lisp b/tests/cfg-tests.lisp index 7b28ef4b4..59ff3dad8 100644 --- a/tests/cfg-tests.lisp +++ b/tests/cfg-tests.lisp @@ -157,6 +157,35 @@ (quil::print-code-list (quil::basic-block-code merged-blk) out)) (format nil "X 0~%Y 0~%Z 0~%"))))) + + + +(defun test-contract-paths-with-loops (src) + (let* ((p (quil::parse-quil src)) + (cfg (cl-quil::program-cfg p :dce t :simplify t)) + (blocks (quil::cfg-blocks cfg))) + ;; test that every label that appears in a conditional or + ;; unconditional edge points to a block that remains in the + ;; simplified CFG + (flet ((labeled-block-exists-p (blk) + (or (not (quil::labeled blk)) + (find (gethash (quil::label-name (quil::labeled blk)) (quil::label-table cfg)) + blocks)))) + (is (every (lambda (blk) + (adt:match quil::outgoing-edge (quil::outgoing blk) + ((quil::conditional-edge _ thenblk elseblk) + (and (labeled-block-exists-p thenblk) + (labeled-block-exists-p elseblk))) + ((quil::unconditional-edge tgtblk) + (labeled-block-exists-p tgtblk)) + (_ t))) + blocks))))) + +(deftest test-path-contractions-with-loops () + (test-contract-paths-with-loops "DECLARE ro BIT;DECLARE shot_count INTEGER[1];LABEL @START;SUB shot_count[0] 1;JUMP-UNLESS @END shot_count[0];JUMP @START;LABEL @END") + (test-contract-paths-with-loops "LABEL @START-LOOP;CCNOT 0 1 2;JUMP @START-LOOP")) + + (deftest test-block-fusion-empty-single-unconditional-self-loop () "Tests the operation of block fusion when the CFG has an unconditional self-loop with a single empty block." (let* ((p (quil::parse-quil "LABEL @START;H 0;JUMP @LOOPER;LABEL @LOOPER;JUMP @START")) @@ -211,3 +240,4 @@ This is a regression test for https://github.com/rigetti/quilc/issues/244" (let* ((program (parse "RESET; PRAGMA PRESERVE_BLOCK; X 0; PRAGMA END_PRESERVE_BLOCK")) (cfg (quil::program-cfg program))) (is (typep (quil::entry-point cfg) 'quil::reset-block)))) +