copy-instance kwargs to overwrite slots

src/ast.lisp

@@ -10,6 +10,10 @@
   "A qubit address."
   (index nil :type unsigned-byte))
 
+(define-copy-struct-instance (qubit :constructor qubit
+                                    :boa-constructor t)
+  index)
+
 (defun qubit= (x y)
   "Do the qubits X and Y have equal indices?"
   (check-type x qubit)
@@ -26,6 +30,10 @@
   "A bare offset into a memory region, used for LOAD and STORE operands."
   (offset nil :read-only t :type integer))
 
+(define-copy-struct-instance (memory-offset :constructor memory-offset
+                                            :boa-constructor t)
+  offset)
+
 (defstruct (memory-ref (:constructor mref (name position &optional descriptor))
                        (:predicate is-mref))
   "A reference into classical memory."
@@ -34,6 +42,10 @@
   ;; The originating memory descriptor. Filled in during analysis.
   (descriptor nil :type (or null memory-descriptor)))
 
+(define-copy-struct-instance (memory-ref :constructor mref
+                                         :boa-constructor t)
+  name position descriptor)
+
 (defun memory-ref= (a b)
   "Do the memory refs A and B represent the same memory ref?"
   (check-type a memory-ref)
@@ -61,6 +73,10 @@
   (value nil :type number)
   (value-type quil-real :type quil-type))
 
+(define-copy-struct-instance (constant :constructor constant
+                                       :boa-constructor t)
+  value value-type)
+
 (defun constant= (x y)
   "Do the constants X and Y have equal types and values?"
   (check-type x constant)
@@ -81,6 +97,10 @@
   "A formal parameter. Corresponds to names prepended with `%' in Quil. Represents a numerical value or a classical memory reference."
   (name nil :read-only t :type string))
 
+(define-copy-struct-instance (param :constructor param
+                                    :boa-constructor t)
+  name)
+
 (defun param= (x y)
   "Do parameters X and Y have the same name?"
   (check-type x param)
@@ -93,6 +113,10 @@
   "A formal argument. Represents a placeholder for a qubit or a memory reference."
   (name nil :read-only t :type string))
 
+(define-copy-struct-instance (formal :constructor formal
+                                     :boa-constructor t)
+  name)
+
 (defun formal= (x y)
   "Do formal arguments X and Y have the same name?"
   (check-type x formal)
@@ -122,6 +146,9 @@ EXPRESSION should be an arithetic (Lisp) form which refers to LAMBDA-PARAMS."
   (lambda-params nil :read-only t)
   (expression nil :read-only t))
 
+(define-copy-struct-instance (delayed-expression :constructor %delayed-expression)
+  params lambda-params expression)
+
 (defun make-delayed-expression (params lambda-params expression)
   "Make a DELAYED-EXPRESSION object initially with parameters PARAMS (probably a list of PARAM objects), lambda parameters LAMBDA-PARAMS, and the form EXPRESSION."
   (check-type lambda-params symbol-list)
@@ -509,10 +536,8 @@ This replicates some of the behavior of CL-QUIL.CLIFFORD::PAULI, but it extends
   prefactor
   arguments)
 
-(defmethod copy-instance ((term pauli-term))
-  (make-pauli-term :pauli-word (pauli-term-pauli-word term)
-                   :prefactor (pauli-term-prefactor term)
-                   :arguments (pauli-term-arguments term)))
+(define-copy-struct-instance (pauli-term)
+  pauli-word prefactor arguments)
 
 (defmethod gate-definition-qubits-needed ((gate exp-pauli-sum-gate-definition))
   (length (exp-pauli-sum-gate-definition-arguments gate)))
@@ -1162,6 +1187,22 @@ Each addressing mode will be a vector of symbols:
   (dagger-operator     operator-description)
   (forked-operator     operator-description))
 
+(define-copy-struct-instance (named-operator :constructor named-operator
+                                             :boa-constructor t)
+  (_ named-operator%0))
+
+(define-copy-struct-instance (controlled-operator :constructor controlled-operator
+                                                  :boa-constructor t)
+  (_ controlled-operator%0))
+
+(define-copy-struct-instance (dagger-operator :constructor dagger-operator
+                                              :boa-constructor t)
+  (_ dagger-operator%0))
+
+(define-copy-struct-instance (forked-operator :constructor forked-operator
+                                              :boa-constructor t)
+  (_ forked-operator%0))
+
 (setf (documentation 'named-operator 'function)
       "Describes a gate using a string name, which is later looked up in a table of DEFGATE definitions.  In Quil code, this corresponds to a raw gate name, like ISWAP.")
 (setf (documentation 'controlled-operator 'function)
@@ -1337,22 +1378,43 @@ If this slot is not supplied, then the gate is considered *anonymous*. If this i
 N.B. This slot should not be accessed directly! Consider using GATE-APPLICATION-GATE, or, if you really know what you're doing, %SET-GATE-APPLICATION-GATE."))
   (:documentation "An instruction representing an application of a known gate."))
 
-(defmethod copy-instance ((application gate-application))
-  (if (slot-boundp application 'name-resolution)
-      (make-instance 'gate-application
-                     :operator (copy-instance (application-operator application))
-                     :parameters (mapcar #'copy-instance
-                                         (application-parameters application))
-                     :arguments (mapcar #'copy-instance
-                                        (application-arguments application))
-                     :name-resolution (gate-application-resolution application))
-      (make-instance 'gate-application
-                     :operator (copy-instance (application-operator application))
-                     :parameters (mapcar #'copy-instance
-                                         (application-parameters application))
-                     :arguments (mapcar #'copy-instance
-                                        (application-arguments application))
-                     :gate (copy-instance (gate-application-gate application)))))
+(defmethod copy-instance ((application gate-application)
+                          &key (operator nil operatorp)
+                            (parameters nil parametersp)
+                            (arguments nil argumentsp)
+                            (name-resolution nil name-resolution-p)
+                            (gate nil gatep))
+  "Do a deep copy, and check for errors resulting from inadvisible combos of NAME-RESOLUTION and GATE."
+  (let* ((copy (make-instance 'gate-application
+                              :operator (if operatorp
+                                            operator
+                                            (copy-instance (application-operator application)))
+                              :parameters (if parametersp
+                                              parameters
+                                              (mapcar #'copy-instance (application-parameters application)))
+                              :arguments (if argumentsp
+                                             arguments
+                                             (mapcar #'copy-instance (application-arguments application))))))
+    (cond ((and name-resolution-p gatep)
+           (error "Mutually exclusive options :NAME-RESOLUTION and :GATE in COPY-INSTANCE GATE-APPLICATION"))
+
+          (gatep
+           (%set-gate-application-gate gate copy))
+
+          (name-resolution-p
+           (setf (slot-value copy 'name-resolution)
+                 name-resolution))
+
+          ((slot-boundp application 'name-resolution)
+           (setf (slot-value copy 'name-resolution)
+                 (gate-application-resolution application)))
+
+          ((slot-boundp application 'gate)
+           (%set-gate-application-gate (copy-instance (gate-application-gate application))
+                                       copy))
+
+          (t (error "Neither :NAME-RESOLUTION nor :GATE supplied in COPY-INSTANCE GATE-APPLICATION")))
+    copy))
 
 (defgeneric gate-application-gate (app)
   ;; See the actual definition of this in gates.lisp.
@@ -1765,21 +1827,33 @@ For example,
    :executable-code #())
   (:documentation "A representation of a parsed Quil program, in which instructions have been duly sorted into their various categories (e.g. definitions vs executable code), and internal references have been resolved."))
 
-(defmethod copy-instance ((parsed-program parsed-program))
-  (let ((pp (make-instance 'parsed-program)))
-    (setf (parsed-program-gate-definitions pp)
-          (map 'list #'copy-instance
-               (parsed-program-gate-definitions parsed-program)))
-    (setf (parsed-program-circuit-definitions pp)
-          (map 'list #'copy-instance
-               (parsed-program-circuit-definitions parsed-program)))
-    (setf (parsed-program-memory-definitions pp)
-          (map 'list #'copy-instance
-               (parsed-program-memory-definitions parsed-program)))
-    (setf (parsed-program-executable-code pp)
-          (map 'vector #'copy-instance
-               (parsed-program-executable-code parsed-program)))
-    pp))
+(defmethod copy-instance ((parsed-program parsed-program)
+                          &key (gate-definitions nil gate-definitions-p)
+                            (circuit-definitions nil circuit-definitions-p)
+                            (memory-definitions nil memory-definitions-p)
+                            (executable-code nil executable-code-p))
+  "Do a deep copy."
+  (make-instance 'parsed-program
+                 :gate-definitions
+                 (if gate-definitions-p
+                     gate-definitions
+                     (mapcar #'copy-instance
+                             (parsed-program-gate-definitions parsed-program)))
+                 :circuit-definitions
+                 (if circuit-definitions-p
+                     circuit-definitions
+                     (mapcar #'copy-instance
+                             (parsed-program-circuit-definitions parsed-program)))
+                 :memory-definitions
+                 (if memory-definitions-p
+                     memory-definitions
+                     (mapcar #'copy-instance
+                             (parsed-program-memory-definitions parsed-program)))
+                 :executable-code
+                 (if executable-code-p
+                     executable-code
+                     (map 'vector #'copy-instance
+                          (parsed-program-executable-code parsed-program)))))
 
 (defvar *print-parsed-program-text* nil
   "When T, PRINT-OBJECT on a PARSED-PROGRAM will include the program text. Otherwise, only the number of instructions is printed.")

src/classical-memory.lisp

@@ -52,6 +52,9 @@
   ;; Context token, available for later resolution
   (lexical-context nil :read-only t :type (or null token)))
 
+(define-copy-struct-instance (memory-descriptor)
+  name type length sharing-parent sharing-offset-alist lexical-context)
+
 (defmethod lexical-context ((obj memory-descriptor))
   (memory-descriptor-lexical-context obj))
 
@@ -75,6 +78,9 @@
   ;; The size of this map in bits.
   (size-in-bits nil :read-only t :type unsigned-byte))
 
+(define-copy-struct-instance (memory-alias)
+  name root-memory type length starting-bit size-in-bits)
+
 (defstruct memory-model
   "A fully parsed-out model for the hierarchical memory of a program."
   ;; The alignment, sizeof(REAL), and sizeof(INTEGER), all measured in
@@ -92,6 +98,9 @@
   ;; A list of MEMORY-ALIAS instances which refer to the roots.
   (aliases nil :read-only t :type list))
 
+(define-copy-struct-instance (memory-model)
+  alignment real-bits integer-bits sizeof names roots aliases)
+
 (defun dividesp (d n)
   "Does D divide N?"
   (zerop (mod n d)))

src/frontend-utilities.lisp

@@ -5,18 +5,84 @@
 
 (in-package #:cl-quil.frontend)
 
-(defgeneric copy-instance (instance)
+(defgeneric copy-instance (instance &key &allow-other-keys)
   (:documentation
    "Create a shallow copy of the object INSTANCE.
-WARNING: The default will work for instances of \"idiomatic\" classes that aren't doing too many crazy things.")
-  (:method ((instance t))
+
+The default will work for instances of \"idiomatic\" subclasses of `standard-object' that aren't doing too
+many crazy things. If you need different behavior, like a deep copy that reallocates some substructure, you
+must define a method yourself.
+
+Subclasses of `structure-object' (i.e. those defined by `defstruct') cannot be generically copied in a
+portable way, as the MOP does not specify operations on `structure-class'. (The SBCL MOP happens to apply to
+`structure-class' in addition to `standard-class', but depending on that fact seems unwise.) If you need to
+`copy-instance' a `structure-object', use `define-copy-struct-instance' to define a specialized method.")
+  (:method ((instance standard-object) &rest slot-overwrites &key &allow-other-keys)
     (let* ((class (class-of instance))
            (copy (allocate-instance class)))
       (dolist (slot (mapcar #'closer-mop:slot-definition-name (closer-mop:class-slots class)))
         (when (slot-boundp instance slot)
           (setf (slot-value copy slot)
                 (slot-value instance slot))))
-      copy)))
+      (apply #'reinitialize-instance copy slot-overwrites))))
+
+(defmacro define-copy-struct-instance ((structure-class
+                                        &key constructor
+                                          (conc-name "" conc-name-p)
+                                          boa-constructor)
+                                       &body slot-names-and-readers)
+  "Define a method on `copy-instance' specialized on STRUCTURE-CLASS.
+
+CONSTRUCTOR, if supplied, should name the constructor function defined by `defstruct'. If the long-form
+`:constructor' argument to `defstruct' is used to define a \"boa-constructor\", you must also supply
+BOA-CONSTRUCTOR as non-NIL.
+
+CONC-NAME, if supplied, should be the same as passed to `defstruct'.
+
+Each of the SLOT-NAMES-AND-READERS should be either a bare symbol, which should match the symbol passed as a
+slot-name to `defstruct', or a list (INITARG READER), where INITARG is a keyword suitable for the constructor
+defined by `defstruct' and READER is the name of a reader function for the slot. If the symbol for is
+supplied, it will be combined with CONC-NAME to produce a reader, and converted into a keyword to produce an
+initarg. If BOA-CONSTRUCTOR is non-NIL and the list form is supplied, the INITARG will be ignored.
+
+If BOA-CONSTRUCTOR is non-NIL, the SLOT-NAMES-AND-READERS must be listed in the same order as they appear in
+the `defstruct' form's `:constructor' arglist."
+  (let* ((conc (if conc-name-p conc-name (format nil "~A-" structure-class)))
+         (instance (gensym "INSTANCE-")))
+    (labels ((format-symbol (format-string &rest format-args)
+               (intern (apply #'format nil format-string format-args)
+                       (symbol-package structure-class)))
+             (reader-name (slot-name)
+               (format-symbol "~A~A" conc slot-name))
+             (make-keyword (slot-name)
+               (if (keywordp slot-name) slot-name
+                   (intern (symbol-name slot-name)
+                           :keyword)))
+             (kwarg-spec (initarg var-name supplied-p)
+               `((,initarg ,var-name) nil ,supplied-p))
+             (boa-constructor-arg (supplied-p new-value reader)
+               `(if ,supplied-p ,new-value
+                    (,reader ,instance))))
+      (let* ((ctor (or constructor
+                       (format-symbol "MAKE-~A" structure-class)))
+
+             (initargs (loop :for slot-spec :in slot-names-and-readers
+                             :if (symbolp slot-spec)
+                               :collect (make-keyword slot-spec)
+                             :else
+                               :collect (make-keyword (first slot-spec))))
+             (readers (loop :for slot-spec :in slot-names-and-readers
+                            :if (symbolp slot-spec)
+                              :collect (reader-name slot-spec)
+                            :else
+                              :collect (second slot-spec)))
+             (slot-args (mapcar #'a:make-gensym initargs))
+             (supplied-p (mapcar #'a:make-gensym initargs))
+             (boa-constructor-args (mapcar #'boa-constructor-arg supplied-p slot-args readers)))
+        `(defmethod copy-instance ((,instance ,structure-class)
+                                   &key ,@(mapcar #'kwarg-spec initargs slot-args supplied-p))
+           (,ctor ,@(if boa-constructor boa-constructor-args
+                        (a:alist-plist (mapcar #'cons initargs boa-constructor-args)))))))))
 
 (defmacro dohash (((key val) hash &optional ret) &body body)
   `(loop :for ,key :being :the :hash-keys :of ,hash

src/magicl-constructors.lisp

@@ -103,3 +103,10 @@ NOTE: When TYPE is not specified the elemnets in LIST are coerced to +DEFAULT-MA
                      nil)))
         (incf (magicl:tref m row col) entry)))
     m))
+
+(defmethod copy-instance ((tensor magicl:abstract-tensor) &key)
+  "Copy a MagiCL tensor, allocating a new array for underlying storage.
+
+No slot-overwrite keyword args are accepted, because the underlying representation of MagiCL matrices should
+be treated as opaque."
+  (magicl:deep-copy-tensor tensor))