Cleanups having to do with fidelity of sets of instructions

app/tests/rpcq-tests.lisp

@@ -54,8 +54,8 @@
                          "0-1" (make-hash-table))))
              (specs (plist-isa-subtable
                      "1Q" (plist-isa-subtable
-                           "0" (plist-isa-subtable "f1QRB" 0.98)
-                           "1" (plist-isa-subtable "f1QRB" 0.98))
+                           "0" (plist-isa-subtable "f1QRB" 0.98d0)
+                           "1" (plist-isa-subtable "f1QRB" 0.98d0))
                      "2Q" (plist-isa-subtable
                            "0-1" (make-hash-table))))
              (target-device (make-instance 'rpcq::|TargetDevice|
@@ -90,8 +90,8 @@
                          "0-1" (make-hash-table))))
              (specs (plist-isa-subtable
                      "1Q" (plist-isa-subtable
-                           "0" (plist-isa-subtable "f1QRB" 0.98)
-                           "1" (plist-isa-subtable "f1QRB" 0.98))
+                           "0" (plist-isa-subtable "f1QRB" 0.98d0)
+                           "1" (plist-isa-subtable "f1QRB" 0.98d0))
                      "2Q" (plist-isa-subtable
                            "0-1" (make-hash-table))))
              (target-device (make-instance 'rpcq::|TargetDevice|

src/addresser/fidelity-addresser.lisp

@@ -26,6 +26,13 @@
 (defmethod cost-flatten ((cost fidelity-cost))
   (fidelity-cost-value cost))
 
+(defun calculate-instructions-log-fidelity (instructions chip-specification)
+  "Calculates the fidelity of a sequence of native INSTRUCTIONS on a chip with architecture governed by CHIP-SPECIFICATION (and with assumed perfect parallelization across resources)."
+  (flet ((log-squared-fidelity (instr)
+           (expt (log (get-instruction-fidelity instr chip-specification))
+                 2)))
+    (reduce #'+ instructions :key #'log-squared-fidelity :initial-value 0.0d0)))
+
 (defun application-fidelity-cost (state instr)
   "Compute the fidelity cost of INSTR, with respect to the provided addresser state."
   ;; calculate log-infidelity coming from INSTR, using recombination:
@@ -40,9 +47,6 @@
              (when (rewiring-assigned-for-instruction-qubits-p l2p instr)
                (rewire-l2p-instruction l2p instr-copy))
              (expand-to-native-instructions (list instr-copy) chip-spec))))
-    ;; (when (= 1 (length (application-arguments instr)))
-    ;;   (setf instruction-expansion (append instruction-expansion (list (make-instance 'measure-discard :qubit (qubit (apply-rewiring-l2p l2p (qubit-index (first (application-arguments instr))))))))))
-
     ;; compute the naive cost
     (let ((instr-cost (calculate-instructions-log-fidelity instruction-expansion chip-spec)))
       ;; then, see if there's a non-naive cost available
@@ -75,9 +79,8 @@
     (flet ((1q-cost (gate physical-qubit)
              (a:when-let* ((chip-spec (addresser-state-chip-specification state))
                            (hardware-object (lookup-hardware-object chip-spec gate))
-                           (instrs (expand-to-native-instructions (list gate) chip-spec))
                            (rewired-instrs
-                            (loop :for instr :in instrs
+                            (loop :for instr :in (expand-to-native-instructions (list gate) chip-spec)
                                   :for rewired-instr := (copy-instance instr)
                                   :do (setf (application-arguments rewired-instr)
                                             (mapcar (constantly (qubit physical-qubit))

src/addresser/logical-schedule.lisp

@@ -29,8 +29,8 @@
 ;;;
 ;;; where the arrow A ---> B means that A logically follows B.
 ;;;
-;;; The logical scheduler (defined below) holds a set of instructions and their
-;;; resource dependencies. In particular, it maintain a list of 'first' or 'top'
+;;; The logical schedule (defined below) holds a set of instructions and their
+;;; resource dependencies. In particular, it maintains a list of 'first' or 'top'
 ;;; instructions (corresponding to the right fringe of the above diagram, i.e. X
 ;;; 0 and H 3), a set of 'last' or 'bottom' instructions (corresponding to the
 ;;; left fringe, i.e. CNOT 1 3), as well as hash tables storing information on
@@ -169,22 +169,26 @@
                          (instruction-resources instr2)))
 
 ;;;
-;;; the core logical scheduler class and some of its utilities
+;;; the core logical schedule class and some of its utilities
 ;;;
 
 (defclass logical-schedule ()
-  ((first-instrs :initform nil
-                 :accessor lschedule-first-instrs
-                 :documentation "List of the instructions appearing at the \"top\" of a logical scheduler.  Excepting COMMUTING_BLOCKS threads, these instructions are guaranteed to occupy disjoint collections of resources.")
-   (last-instrs :initform nil
-                :accessor lschedule-last-instrs
-                :documentation "List of the instructions appearing at the \"bottom\" of a logical scheduler.  These are sorted topologically ascending: earlier items in the list come logically after deeper items in the list.")
-   (later-instrs :initform (make-instr-hash-table)
-                 :accessor lschedule-later-instrs
-                 :documentation "Hash table mapping instruction to a list of instructions after it.")
-   (earlier-instrs :initform (make-instr-hash-table)
-                   :accessor lschedule-earlier-instrs
-                   :documentation "Hash table mapping instruction to a list of instructions before it."))
+  ((first-instrs
+    :initform nil
+    :accessor lschedule-first-instrs
+    :documentation "List of the instructions appearing at the \"top\" of a logical schedule.  Excepting COMMUTING_BLOCKS threads, these instructions are guaranteed to occupy disjoint collections of resources.")
+   (last-instrs
+    :initform nil
+    :accessor lschedule-last-instrs
+    :documentation "List of the instructions appearing at the \"bottom\" of a logical schedule.  These are sorted topologically ascending: earlier items in the list come logically after deeper items in the list.")
+   (later-instrs
+    :initform (make-instr-hash-table)
+    :accessor lschedule-later-instrs
+    :documentation "Hash table mapping instruction to a list of instructions after it.")
+   (earlier-instrs
+    :initform (make-instr-hash-table)
+    :accessor lschedule-earlier-instrs
+    :documentation "Hash table mapping instruction to a list of instructions before it."))
   (:documentation "Data structure used to track the logical precedence of instructions in a straight-line Quil program."))
 
 (defun make-instr-hash-table (&optional size)
@@ -658,55 +662,15 @@ Returns the reduction of all bumped values by COMBINE-VALUES, and a hash table m
   (+ (length (lschedule-topmost-instructions lschedule))
      (hash-table-count (lschedule-earlier-instrs lschedule))))
 
-(defun lschedule-calculate-log-fidelity (lschedule chip-spec)
-  (labels
-      ((get-fidelity (instr)
-         (labels ((warn-and-skip (instr)
-                    (format-noise "Unknown fidelity for ~/cl-quil::instruction-fmt/. Skipping." instr)
-                    (return-from get-fidelity 0d0)))
-           (let (fidelity)
-             (typecase instr
-               (measurement
-                (let* ((qubit-index (qubit-index (measurement-qubit instr)))
-                       (qubit-obj (chip-spec-nth-qubit chip-spec qubit-index))
-                       (specs-obj (gethash (make-measure-binding :qubit qubit-index :target '_)
-                                           (hardware-object-gate-information qubit-obj)))
-                       (measure-fidelity (and specs-obj (gate-record-fidelity specs-obj))))
-                  (unless specs-obj
-                    (warn-and-skip instr))
-                  (setf fidelity measure-fidelity)))
-               (application
-                (let ((obj (lookup-hardware-object chip-spec instr)))
-                  (unless obj
-                    (warn-and-skip instr))
-                  (let ((specs-hash (hardware-object-gate-information obj)))
-                    (unless specs-hash (warn-and-skip instr))
-                    (when (> (hash-table-count specs-hash) 0)
-                      (let ((binding (binding-from-instr instr)))
-                        (dohash ((key val) specs-hash)
-                          (when (binding-subsumes-p key binding)
-                            (setf fidelity (gate-record-fidelity val))))))
-                    (unless fidelity (warn-and-skip instr)))))
-               (otherwise
-                (warn-and-skip instr)))
-             (expt (log fidelity) 2)))))
-    (let ((running-fidelity 0d0))
-      (dolist (instr (lschedule-first-instrs lschedule))
-        (unless (gethash instr (lschedule-earlier-instrs lschedule))
-          (incf running-fidelity (get-fidelity instr))))
-      (maphash (lambda (instr val)
-                 (declare (ignore val))
-                 (incf running-fidelity (get-fidelity instr)))
-               (lschedule-earlier-instrs lschedule))
-      (sqrt running-fidelity))))
 
 (defun lschedule-calculate-fidelity (lschedule chip-spec)
-  "Calculate fidelity as the minimum fidelity of the individual instructions.
-
-  This relies on the fact that the function $\exp\{-\sqrt{\log(x)^2 + \log(y)^2}\}$ is approximately equal to $\min\{x, y\}$ for $x, y \in (0, 1]$."
-  (multiple-value-bind (max-value value-hash)
-      (lschedule-calculate-log-fidelity lschedule chip-spec)
-    (values (exp (- max-value)) value-hash)))
+  "Calculate fidelity as the minimum fidelity of the individual instructions."
+  (let ((min-fidelity 1.0d0)) 
+    (declare (dynamic-extent min-fidelity))
+    (flet ((minimize-fidelity (instr)
+             (setf min-fidelity (min min-fidelity (get-instruction-fidelity instr chip-spec)))))
+      (map-lschedule-in-topological-order lschedule #'minimize-fidelity))
+    min-fidelity))
 
 (defun lschedule-all-instructions (lschedule)
   "Return a list of the instructions of LSCHEDULE."

src/chip/chip-specification.lisp

@@ -809,3 +809,40 @@ Compilers are listed in descending precedence.")
       (adjoin-hardware-object (build-qubit j :type '(:RZ :X/2 :MEASURE)) chip-spec))
     (warm-hardware-objects chip-spec)
     chip-spec))
+
+(declaim (inline warn-and-return-perfect-fidelity))
+(defun warn-and-return-perfect-fidelity (instr)
+  (format-noise "Unknown fidelity for ~/cl-quil::instruction-fmt/. Assuming 1.0d0." instr)
+  1.0d0)
+
+(defun get-instruction-fidelity (instr chip-spec)
+  "Return the double-float fidelity value associated with object INSTR
+on CHIP-SPEC. If no case for on INSTR is matched, the default is
+perfect fidelity (i.e. 1.0)."
+  (declare (values double-float))
+  (typecase instr
+    (measurement
+     (let* ((qubit-index (qubit-index (measurement-qubit instr)))
+            (qubit-obj (chip-spec-nth-qubit chip-spec qubit-index))
+            (specs-obj (gethash (make-measure-binding :qubit qubit-index :target '_)
+                                (hardware-object-gate-information qubit-obj))))
+       (if specs-obj
+           (gate-record-fidelity specs-obj)
+           (warn-and-return-perfect-fidelity instr))))
+
+    (application
+     (let (fidelity)
+       (a:when-let* ((obj        (lookup-hardware-object chip-spec instr))
+                     (specs-hash (hardware-object-gate-information obj))
+                     (binding    (and (plusp (hash-table-count specs-hash))
+                                      (binding-from-instr instr))))
+         (dohash ((key val) specs-hash)
+           (when (binding-subsumes-p key binding)
+             (setf fidelity (gate-record-fidelity val))
+             (setf binding  key))))
+       (or fidelity (warn-and-return-perfect-fidelity instr))))
+
+    (t
+     (warn-and-return-perfect-fidelity instr))))
+
+

src/compilers/approx.lisp

@@ -394,9 +394,7 @@ One can show (cf., e.g., the formulas in arXiv:0205035 with U = M2, E(rho) = V r
 
 (defun fidelity-of-straight-quil (instrs chip-spec)
   "Helper routine for calculating the fidelity of a straight line of Quil instructions against the fidelity information associated to CHIP-SPEC."
-  (let ((ls (make-lschedule)))
-    (append-instructions-to-lschedule ls instrs)
-    (lschedule-calculate-fidelity ls chip-spec)))
+  (calculate-instructions-fidelity instrs chip-spec))
 
 (defun get-canonical-coords-from-diagonal (d)
   "Extracts \"canonical coordinates\" (c1, c2, c3) from a diagonal matrix D which belong to the Weyl chamber satisfying
@@ -732,10 +730,10 @@ NOTE: This routine degenerates to an optimal 2Q compiler when *ENABLE-APPROXIMAT
 
   ;; extract matrix, canonical decomposition
   (destructuring-bind (left1 left2 can right1 right2) (canonical-decomposition instr)
-    (let ((q1 (qubit-index (first (application-arguments instr))))
-          (q0 (qubit-index (second (application-arguments instr))))
+    (let ((q1              (qubit-index (first (application-arguments instr))))
+          (q0              (qubit-index (second (application-arguments instr))))
           (candidate-pairs nil)
-          (chip-spec (compilation-context-chip-specification context)))
+          (chip-spec       (compilation-context-chip-specification context)))
 
       ;; now we manufacture a bunch of candidate circuits
       (dolist (circuit-crafter crafters)
@@ -746,22 +744,22 @@ NOTE: This routine degenerates to an optimal 2Q compiler when *ENABLE-APPROXIMAT
            circuit-crafter
            (with-output-to-string (s) (print-instruction instr s)))
           (handler-case
-              (let* ((center-circuit (funcall circuit-crafter can))
-                     (ls (append-instructions-to-lschedule (make-lschedule) center-circuit))
-                     (circuit-cost (or (and chip-spec (lschedule-calculate-fidelity ls chip-spec))
-                                       1d0))
+              (let* ((center-circuit     (funcall circuit-crafter can))
+                     (circuit-cost       (or (and chip-spec (calculate-instructions-fidelity center-circuit chip-spec))
+                                             1d0))
                      (sandwiched-circuit (append (list left1 left2)
                                                  center-circuit
                                                  (list right1 right2)))
-                     (m (make-matrix-from-quil sandwiched-circuit
-                                               :relabeling (standard-qubit-relabeler `(,q1 ,q0)))))
-                (let ((infidelity (fidelity-coord-distance
-                                   (mapcar #'constant-value (application-parameters can))
-                                   (get-canonical-coords-from-diagonal
-                                    (nth-value 1 (orthogonal-decomposition m))))))
-                  (format-noise " for infidelity ~A." infidelity)
-                  (push (cons (* circuit-cost (- 1 infidelity)) sandwiched-circuit)
-                        candidate-pairs)))
+                     (m                  (make-matrix-from-quil sandwiched-circuit
+                                                                :relabeling (standard-qubit-relabeler `(,q1 ,q0))))
+                     (infidelity         (fidelity-coord-distance
+                                          (mapcar #'constant-value (application-parameters can))
+                                          (get-canonical-coords-from-diagonal
+                                           (nth-value 1 (orthogonal-decomposition m))))))
+                (format-noise " for infidelity ~A." infidelity)
+                (push (cons (* circuit-cost (- 1 infidelity))
+                            sandwiched-circuit)
+                      candidate-pairs))
             (compiler-does-not-apply () nil))))
 
       ;; now vomit the results

src/compressor/compressor.lisp

@@ -87,17 +87,14 @@
     ;; sift through it for durations
     (lschedule-calculate-duration lschedule chip-specification)))
 
-(defun calculate-instructions-log-fidelity (instructions chip-specification)
-  "Calculates the fidelity of a sequence of native INSTRUCTIONS on a chip with architecture governed by CHIP-SPECIFICATION (and with assumed perfect parallelization across resources)."
-  (let ((lschedule (make-lschedule)))
-    ;; load up the logical schedule
-    (append-instructions-to-lschedule lschedule instructions)
-    ;; sift through it for fidelities
-    (lschedule-calculate-log-fidelity lschedule chip-specification)))
 
 (defun calculate-instructions-fidelity (instructions chip-specification)
-  "Calculates the fidelity of a sequence of native INSTRUCTIONS on a chip with architecture governed by CHIP-SPECIFICATION (and with assumed perfect parallelization across resources)."
-  (exp (- (calculate-instructions-log-fidelity instructions chip-specification))))
+  "Calculates the fidelity of a sequence of native INSTRUCTIONS on a chip with architecture governed by CHIP-SPECIFICATION (and with assumed perfect parallelization across resources).
+
+The fidelity returned is a real (double-float) number in the interval [0.0, 1.0]"
+  (flet ((instr-fidelity (instr)
+           (get-instruction-fidelity instr chip-specification))) 
+    (reduce #'min instructions :key #'instr-fidelity :initial-value 1.0d0)))
 
 (defun find-noncommuting-instructions (node)
   "Return at most *REWRITING-PEEPHOLE-SIZE* of the earliest instructions below NODE,
@@ -536,14 +533,10 @@ other's."
                         (tr (magicl:trace prod))
                         (trace-fidelity (/ (+ n (abs (* tr tr)))
                                            (+ n (* n n))))
-                        (ls-reduced (make-lschedule))
-                        (ls-reduced-decompiled (make-lschedule))
                         (chip-spec (compilation-context-chip-specification context)))
-                   (append-instructions-to-lschedule ls-reduced reduced-instructions)
-                   (append-instructions-to-lschedule ls-reduced-decompiled reduced-decompiled-instructions)
                    (assert (>= (* trace-fidelity
-                                  (lschedule-calculate-fidelity ls-reduced-decompiled chip-spec))
-                               (lschedule-calculate-fidelity ls-reduced chip-spec))
+                                  (calculate-instructions-fidelity reduced-decompiled-instructions chip-spec))
+                               (calculate-instructions-fidelity reduced-instructions chip-spec))
                            ()
                            "During careful checking of instruction compression, ~
                             the recomputed instruction sequence has an ~

src/utilities.lisp

@@ -91,7 +91,7 @@ appropriate method of comparison."
   (check-type program parsed-program)
   (check-type chip chip-specification)
   (calculate-instructions-fidelity
-   (coerce (parsed-program-executable-code program) 'list)
+   (parsed-program-executable-code program)
    chip))
 
 (defun prog-find-top-pragma (parsed-prog pragma)