Add PRAGMA to allow user control of swap search strategy

src/addresser/addresser-common.lisp

@@ -102,6 +102,15 @@ Returns a list of link indices, along with an updated list of rewirings tried.")
 (defvar *addresser-rewiring-swap-search-type* ':a*
   "The type of swap search the addresser should use when doing move-to-rewiring.")
 
+
+(defun prog-rewiring-search-algorithm (parsed-prog)
+  "Return a value of type CL-QUIL::ADDRESSER-SEARCH-TYPE. If PARSED-PROG
+includes a REWIRING_SEARCH pragma, respect it. Otherwise return the
+value of *ADDRESSER-REWIRING-SWAP-SEARCH-TYPE*"
+  (a:if-let (pragma (prog-find-top-pragma parsed-prog 'pragma-rewiring-search))
+    (pragma-swap-search-type pragma)
+    *addresser-rewiring-swap-search-type*))
+
 ;;; A pseudoinstruction class used to send directives to the addresser
 (defclass application-force-rewiring (application)
   ((target-rewiring :initarg :target
@@ -638,6 +647,7 @@ Optional arguments:
    If INITIAL-REWIRING is not provided this option has no effect.
 ")
   (:method (state instrs &key (initial-rewiring nil) (use-free-swaps nil))
+    (declare (ignorable initial-rewiring))
     (format-noise "DO-GREEDY-ADDRESSING: entrance.")
     (with-slots (chip-spec lschedule working-l2p chip-sched initial-l2p) state
       (let ((*addresser-use-free-swaps* (or use-free-swaps initial-l2p)))

src/compiler-hook.lisp

@@ -26,9 +26,12 @@
                       chip-specification
                       &key
                         (protoquil nil)
-                        (rewiring-type (prog-initial-rewiring-heuristic parsed-program chip-specification))
+                        (rewiring-type
+                         (prog-initial-rewiring-heuristic parsed-program chip-specification))
                         (transforms *standard-pre-compilation-transforms*)
-                        (destructive nil))
+                        (destructive nil)
+                        (*addresser-rewiring-swap-search-type*
+                         (prog-rewiring-search-algorithm parsed-program)))
   "Runs a full compiler pass on a parsed-program object.
 
 Arguments:

src/package.lisp

@@ -509,6 +509,9 @@
    #:pragma-initial-rewiring            ; CLASS
    #:pragma-initial-rewiring-rewiring   ; ACCESSOR
 
+   #:pragma-rewiring-search             ; CLASS
+   #:pragma-swap-search-type            ; ACCESSOR
+
    #:pragma-rewiring
    #:pragma-rewiring-type               ; FUNCTION
    )

src/pragmas.lisp

@@ -117,6 +117,27 @@ Expected syntax: PRAGMA INITIAL_REWIRING [NAIVE|PARTIAL|GREEDY|RANDOM]")
   (:display-string
    (prin1-to-string (symbol-name rewiring-type))))
 
+
+(define-pragma "REWIRING_SEARCH" pragma-rewiring-search
+  (:documentation "PRAGMA denoting the search strategy to be used for selecting the
+SWAPs that bring a logical-to-physical rewiring to a target rewiring.
+
+Compilation resource requirements may vary according to the rewiring search type used. 
+
+Expected syntax: PRAGMA REWIRING_SEARCH [\"A*\"|\"GREEDY-QUBIT\"|\"GREEDY-PATH\"]")
+  (:global t)
+  (:slots (swap-search-type cl-quil::addresser-search-type))
+  (:freeform-string rewiring-swap-search-type-string)
+  (:initialization
+   (setf swap-search-type
+         (cond ((string= rewiring-swap-search-type-string "A*") ':a*)
+               ((string= rewiring-swap-search-type-string "GREEDY_QUBIT") ':greedy-qubit)
+               ((string= rewiring-swap-search-type-string "GREEDY_PATH") ':greedy-path)
+               (t
+                (error "Invalid PRAGMA REWIRING_SEARCH: ~A" rewiring-swap-search-type-string)))))
+  (:display-string
+   (prin1-to-string (symbol-name swap-search-type))))
+
 (defun parsed-program-has-pragma-p (parsed-program &optional (pragma-type 'pragma))
   "Return T if PARSED-PROGRAM's executable code contains any pragma. Optionally use PRAGMA-TYPE to restrict to a particular pragma type."
   (some (a:rcurry #'typep pragma-type)