From 28e9b82a1293597ebac2fb892f3e3b00f1968f47 Mon Sep 17 00:00:00 2001 From: Colin O'Keefe Date: Mon, 23 Sep 2024 10:52:36 -0700 Subject: [PATCH 1/7] Adds a coalton AST for Quil --- src/coalton/ast/raw.lisp | 44 +++ src/coalton/ast/unresolved.lisp | 639 ++++++++++++++++++++++++++++++++ 2 files changed, 683 insertions(+) create mode 100644 src/coalton/ast/raw.lisp create mode 100644 src/coalton/ast/unresolved.lisp diff --git a/src/coalton/ast/raw.lisp b/src/coalton/ast/raw.lisp new file mode 100644 index 00000000..59cab9f2 --- /dev/null +++ b/src/coalton/ast/raw.lisp @@ -0,0 +1,44 @@ +(defpackage #:quil/ast/raw + (:use #:coalton) + (:documentation "Native Cl-QUIL and CL-QUIL.FRONTEND Types") + (:export + #:Program + #:Instruction + #:QubitArg + #:Param + #:MRef + #:RefArg + #:QuilType)) + +(in-package #:quil/ast/raw) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (repr :native cl-quil:quil-type) + (define-type QuilType) + + (repr :native cl-quil:parsed-program) + (define-type Program) + + (repr :native (cl:or cl-quil:qubit cl-quil:formal)) + (define-type QubitArg) + + (repr :native (cl:or cl-quil:formal cl-quil:memory-ref)) + (define-type RefArg) + + (repr :native cl-quil:memory-ref) + (define-type MRef) + + (repr :native (cl:or cl-quil:param + cl-quil.frontend:delayed-expression + cl-quil:constant cl:null)) + (define-type Param) + + (repr :native (cl:or cl-quil:instruction + cl-quil:memory-descriptor + cl-quil:jump-target + cl-quil:gate-definition + cl-quil:circuit-definition)) + (define-type Instruction)) diff --git a/src/coalton/ast/unresolved.lisp b/src/coalton/ast/unresolved.lisp new file mode 100644 index 00000000..e9c8514e --- /dev/null +++ b/src/coalton/ast/unresolved.lisp @@ -0,0 +1,639 @@ +(defpackage #:quil/ast/unresolved + (:use #:coalton) + (:import-from #:coalton-library/classes #:map) + (:import-from #:coalton) + (:local-nicknames + (#:quil #:cl-quil.frontend) + (#:complex #:coalton-library/math/complex) + (#:raw #:quil/ast/raw))) + +(in-package #:quil/ast/unresolved) + +(named-readtables:in-readtable coalton:coalton) + + +;;; HELPERS TO COPE WITH RESOLVING ARITHMETIC EXPRESSIONS TO THEIR +;;; "RAW" CL-QUIL REPRESENTATIONS + +(cl:defun get-expr-params (expr) + "Helper function. Returns a list suitable for filling the PARAMETERS +slot of a DELAYED-EXPRESSION instance." + (cl:etypecase expr + (cl:null cl:nil) + (quil:param (cl:list expr)) + (quil:constant cl:nil) + (quil:delayed-expression + (quil:delayed-expression-params expr)))) + +(cl:defun get-expr-lambda-params (expr) + "Helper function. Returns a list of symbols suitable for filling the +LAMBDA-PARAMETERS slot of a DELAYED-EXPRESSION instance" + (cl:etypecase expr + (cl:null cl:nil) + (quil:param (cl:list (cl:make-symbol (quil:param-name expr)))) + (quil:constant cl:nil) + (quil:delayed-expression + (quil:delayed-expression-lambda-params expr)))) + +(cl:defun get-expr-exprs (expr) + "Helper function, returns a value that can appear as a +sub-expression (a SEXP) in a DELAYED-EXPRESSIONS instance's EXPRESSION +slot." + (cl:etypecase expr + (cl:null cl:nil) + (quil:param (cl:make-symbol (quil:param-name expr))) + (quil:constant (quil:constant-value expr)) + (quil:delayed-expression + (quil:delayed-expression-expression expr)))) + +(cl:defmacro combine-params (str arg1 cl:&optional arg2) + "Generates a form to produce a DELAYED-EXPRESSION out of the values of +forms ARG1 and ARG2, which may be anything that can appear in a +parameter postion of a gate application." + (cl:let* ((var1 (cl:gensym "VAR")) + (var2 (cl:gensym "VAR")) + (vars (cl:list var1 var2)) + (new-params (cl:gensym "PARAMS")) + (new-lambda-params (cl:gensym "LAMBDAPARAMS")) + (new-expression (cl:gensym "EXPR")) + (op (cl:gensym "OP"))) + `(let ((,var1 (expr-to-raw ,arg1)) + (,var2 ,(cl:if arg2 + `(expr-to-raw ,arg2) + `(lisp raw:Param () cl:nil)))) + (lisp raw:Param ,(cl:if (cl:stringp str) vars (cl:cons str vars)) + (cl:let* ((,op (cl:intern (cl:string-upcase ,str) :common-lisp)) + (,new-params + (cl:union (get-expr-params ,var1) + (get-expr-params ,var2) + :test 'cl:equalp)) + (,new-lambda-params + (cl:union (get-expr-lambda-params ,var1) + (get-expr-lambda-params ,var2) + :test 'cl:string=)) + (,new-expression + (cl:list* ,op + (get-expr-exprs ,var1) + (cl:if ,var2 + (cl:list + (get-expr-exprs ,var2)) + cl:nil)))) + (quil:make-delayed-expression + ,new-params ,new-lambda-params ,new-expression)))))) + + +;; HELPER MACROS TO INSTANTIATE CLASSICAL MEMORY OPERATION INSTRUCTIONS + +(cl:defmacro unary-classical-op (name ref) + (cl:let ((rawvar (cl:gensym))) + `(let ((,rawvar (raw-ref-arg ,ref))) + (lisp raw:Instruction (,rawvar) + (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) + :target ,rawvar))))) + +(cl:defmacro binary-classical-op (name left right) + (cl:let ((lvar (cl:gensym)) + (rvar (cl:gensym))) + `(let ((,lvar (raw-ref-arg ,left)) + (,rvar (raw-ref-arg ,right))) + (lisp raw:Instruction (,lvar ,rvar) + (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) + :left ,lvar :right ,rvar))))) + +(cl:defmacro ternary-classical-op (name target left right) + (cl:let ((tvar (cl:gensym)) + (lvar (cl:gensym)) + (rvar (cl:gensym))) + `(let ((,tvar (raw-ref-arg ,target)) + (,lvar (raw-ref-arg ,left)) + (,rvar (raw-ref-arg ,right))) + (lisp raw:Instruction (,tvar ,lvar ,rvar) + (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) + :left ,lvar :right ,rvar :target ,tvar))))) + +(coalton-toplevel + + (define-type Ref + "A Memory Reference" + (Ref String ; name + Ufix ; position + )) + + (declare ref-to-raw (Ref -> raw:Mref)) + (define (ref-to-raw (Ref name loc)) + (lisp raw:Mref (name loc) + (quil:mref name loc))) + + (define-type (Expr :num) + "Arithmetic expressions appearing in gate application parameter + positions and in gate definitions. In the latter case, Memory + references may not appear." + (Add (Expr :num) (Expr :num)) + (Sub (Expr :num) (Expr :num)) + (Mul (Expr :num) (Expr :num)) + (Div (Expr :num) (Expr :num)) + (Pow (Expr :num) (Expr :num)) + (Neg (Expr :num)) + (Const :num) + (Call String (Expr :num)) + (Var String) + (RefExpr Ref)) + + (define-type (MaybeFormal :t) + "A wrapper type representing a value which may in some contexts be +represented by a formal name." + (Actual :t) + (Formal String)) + + (define-type (Gate :num) + ;; User-defeind Gate + (Gate String ; Name + (List (Expr :num)) ; Params + (List (MaybeFormal Ufix))) ; Args + ;; Built-in Gates + ;; -- one qubit gates + (I (MaybeFormal Ufix)) + (X (MaybeFormal Ufix)) + (Y (MaybeFormal Ufix)) + (Z (MaybeFormal Ufix)) + (H (MaybeFormal Ufix)) + (S (MaybeFormal Ufix)) + (T (MaybeFormal Ufix)) + + ;; -- one parameter one qubit gates + (RX (Expr :num) (MaybeFormal Ufix)) + (RY (Expr :num) (MaybeFormal Ufix)) + (RZ (Expr :num) (MaybeFormal Ufix)) + (Phase (Expr :num) (MaybeFormal Ufix)) + + ;; -- two qubit gates + (CNOT (MaybeFormal Ufix) (MaybeFormal Ufix)) + (CZ (MaybeFormal Ufix) (MaybeFormal Ufix)) + (SWAP (MaybeFormal Ufix) (MaybeFormal Ufix)) + (ISWAP (MaybeFormal Ufix) (MaybeFormal Ufix)) + (SQISWAP (MaybeFormal Ufix) (MaybeFormal Ufix)) + + ;; -- three qubit gates + (CSWAP (MaybeFormal Ufix) (MaybeFormal Ufix) (MaybeFormal Ufix)) + (CCNOT (MaybeFormal Ufix) (MaybeFormal Ufix) (MaybeFormal Ufix)) + + ;; -- parameterized two qubit gates + (PSWAP (Expr :num) (MaybeFormal Ufix) (MaybeFormal Ufix)) + (PISWAP (Expr :num) (MaybeFormal Ufix) (MaybeFormal Ufix)) + (XY (Expr :num) (MaybeFormal Ufix) (MaybeFormal Ufix)) + + ;; -- multi-parameter gates + (CAN (Expr :num) (Expr :num) (Expr :num) (MaybeFormal Ufix) (MaybeFormal Ufix)) + (BLOCH (Expr :num) (Expr :num) (Expr :num) (MaybeFormal Ufix)) + + ;; --operators + (DAGGER (Gate :num)) + (CONTROLLED (MaybeFormal Ufix) (Gate :num)) + (FORKED (MaybeFormal Ufix) (List (Expr :num)) (Gate :num))) + + (repr :enum) + (define-type QuilType + "A valid data type for Quil memory." + QuilBit QuilOctet QuilInteger QuilReal) + + (declare raw-quil-type (QuilType -> raw:QuilType)) + (define (raw-quil-type qt) + (match qt + ((QuilBit) (lisp raw:QuilType () quil:quil-bit)) + ((QuilOctet) (lisp raw:QuilType () quil:quil-octet)) + ((QuilInteger) (lisp raw:QuilType () quil:quil-integer)) + ((QuilReal) (lisp raw:QuilType () quil:quil-real)))) + + (define-type MemOffset + "Used in declaring offsets into shared memory declarations" + (MemOffset QuilType Ufix)) + + (define (offset-type (MemOffset type _)) type) + (define (offset-amount (MemOffset _ amount)) amount) + + (define-type (PauliTerm :num) + (PauliTerm String ; pauli word, string of pauli gate names X,Y,Z,I + :num ; prefactor + (List String))) ; arguments + + (define (pauli-term-word (PauliTerm word _ _)) word) + (define (pauli-term-prefactor (PauliTerm _ pf _)) pf) + (define (pauli-term-arguments (PauliTerm _ _ args)) args) + + (define-type (GateDef :num) + (PermuationGateDef (List UFix)) + (StaticGateDef (List :num)) + (ParameterizedGateDef (List String) + (List (Expr :num))) + (PauliSumGateDef (List (PauliTerm :num)) ; terms + (List String) ; params + (List String))) ; arguments + + (define-type ClassicalOperation + ;; Unary + (NotOp (MaybeFormal Ref)) + (NegOp (MaybeFormal Ref)) + ;; Binary + (MoveOp (MaybeFormal Ref) (MaybeFormal Ref)) + (ExchangeOp (MaybeFormal Ref) (MaybeFormal Ref)) + (ConvertOp (MaybeFormal Ref) (MaybeFormal Ref)) + (AndOp (MaybeFormal Ref) (MaybeFormal Ref)) + (IOrOp (MaybeFormal Ref) (MaybeFormal Ref)) + (XOrOp (MaybeFormal Ref) (MaybeFormal Ref)) + (AddOp (MaybeFormal Ref) (MaybeFormal Ref)) + (SubOp (MaybeFormal Ref) (MaybeFormal Ref)) + (MulOp (MaybeFormal Ref) (MaybeFormal Ref)) + (DivOp (MaybeFormal Ref) (MaybeFormal Ref)) + ;; Ternary + (LoadOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref)) + (StoreOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref)) + (EqOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref)) + (GtOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref)) + (GeOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref)) + (LtOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref)) + (LeOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref))) + + (define-type (Instruction :num) + ;; generic gate/circuit application + (ApplyGate (Gate :num)) + ;; include a .quil file + (Include String) + ;; E.g. (Pragma "REWIRING_SEARCH \"A*\"") + (Pragma String) + ;; Classical Memory Declaration + (Memory String ; name + QuilType ; type + UFix ; length + Boolean ; sharing parent + (List MemOffset)) ; sharing offsets + + (GateDefinition String ; name + (GateDef :num)) ; definition + + (CircuitDefinition + String ; name + (List String) ; parameter names + (List String) ; arguments names + (List (Instruction :num))) ; body + + (Label String) + + (ApplyOp ClassicalOperation) + + (Jump String) + (JumpWhen String (MaybeFormal Ref)) + (JumpUnless String (MaybeFormal Ref)) + + Noop + Halt + Wait + + ResetAll + (Reset (MaybeFormal Ufix)) + + (Measure (MaybeFormal Ufix) (MaybeFormal Ref)) + (MeasureDiscard (MaybeFormal Ufix))) + + ;; If non-literal numbertypes are supported, this should be altered + ;; to be something like (real :num, complex :num => ..) + ;; and the Const case be handled to interperet the :num to a type + ;; that quilc can already handle + (declare expr-to-raw (Expr :num -> raw:Param)) + (define (expr-to-raw e) + (match e + ((Add e1 e2) (combine-params "+" e1 e2)) + + ((Sub e1 e2) (combine-params "-" e1 e2)) + + ((Mul e1 e2) (combine-params "*" e1 e2)) + + ((Div e1 e2) (combine-params "/" e1 e2)) + + ((Pow e1 e2) (combine-params "EXPT" e1 e2)) + + ((Neg e1) (combine-params "-" e1)) + + ((Const e) + (lisp raw:Param (e) + (quil:constant e))) + + ((RefExpr rf) + (let ((rr (ref-to-raw rf))) + (lisp raw:Param (rr) + (quil:make-delayed-expression cl:nil cl:nil rr)))) + + ((Var name) + (lisp raw:Param (name) + (quil:param name))) + + ((Call name e) + (combine-params name e)))) + + (declare arg-to-raw ((MaybeFormal Ufix) -> raw:QubitArg)) + (define (arg-to-raw a) + (match a + ((Actual qb) (lisp raw:QubitArg (qb) (quil:qubit qb))) + ((Formal name) (lisp raw:QubitArg (name) (quil:formal name))))) + + (declare raw-gate-application + (String -> (List (Expr :num)) -> (List (MaybeFormal Ufix)) -> raw:Instruction)) + (define (raw-gate-application name params args) + (let ((params* (map expr-to-raw params)) + (args* (map arg-to-raw args))) + (lisp raw:Instruction (name params* args*) + (cl:make-instance 'quil:unresolved-application + :operator (quil:named-operator name) + :parameters params* + :arguments args*)))) + + (define (raw-gate-def name gdef) + (match gdef + ((PermuationGateDef vals) + (lisp raw:Instruction (name vals) + (cl:make-instance 'quil:permutation-gate-definition + :name name :permutation vals :context cl:nil))) + + ((StaticGateDef entries) + (lisp raw:Instruction (name entries) + (cl:make-instance 'quil:static-gate-definition + :name name + :entries entries))) + + ((ParameterizedGateDef params exprs) + (let ((exprs* (map expr-to-raw exprs))) + (lisp raw:instruction (name params exprs*) + (cl:make-instance 'quil:parameterized-gate-definition + :name name + :entries (cl:mapcar 'get-expr-exprs exprs*) + :parameters (cl:mapcar 'cl:make-symbol params))))) + + ((PauliSumGateDef terms params args) + (lisp raw:Instruction (name terms params args) + (cl:make-instance 'quil:exp-pauli-sum-gate-definition + :name name + :arguments (cl:mapcar #'quil:formal args) + :parameters (cl:mapcar 'cl:make-symbol params) + :terms (cl:loop :for term :in terms + :collect (quil:make-pauli-term + :pauli-word (pauli-term-word term) + :prefactor (pauli-term-prefactor term) + :arguments (cl:mapcar #'quil:formal (pauli-term-arguments term))))))))) + + + (define (raw-classical-op op) + (match op + ((NegOp r) + (unary-classical-op "CLASSICAL-NEGATE" r)) + ((NotOp r) + (unary-classical-op "CLASSICAL-NOT" r)) + + ((MoveOp a b) + (binary-classical-op "CLASSICAL-MOVE" a b)) + ((ExchangeOp a b) + (binary-classical-op "CLASSICAL-EXCHANGE" a b)) + ((ConvertOp a b) + (binary-classical-op "CLASSICAL-CONVERT" a b)) + ((AndOp a b) + (binary-classical-op "CLASSICAL-AND" a b)) + ((IOrOp a b) + (binary-classical-op "CLASSICAL-INCLUSIVE-OR" a b)) + ((XOrOp a b) + (binary-classical-op "CLASSICAL-EXCLUSIVE-OR" a b)) + ((AddOp a b) + (binary-classical-op "CLASSICAL-ADDITION" a b)) + ((SubOp a b) + (binary-classical-op "CLASSICAL-SUBTRACTION" a b)) + ((MulOp a b) + (binary-classical-op "CLASSICAL-MULTIPLICATION" a b)) + ((DivOp a b) + (binary-classical-op "CLASSICAL-DIVISION" a b)) + + ((LoadOp a b c) + (ternary-classical-op "CLASSICAL-LOAD" a b c)) + ((StoreOp a b c) + (ternary-classical-op "CLASSICAL-STORE" a b c)) + ((EqOp a b c) + (ternary-classical-op "CLASSICAL-EQUALITY" a b c)) + ((GtOp a b c) + (ternary-classical-op "CLASSICAL-GREATER-THAN" a b c)) + ((GeOp a b c) + (ternary-classical-op "CLASSICAL-GREATER-EQUAL" a b c)) + ((LtOp a b c) + (ternary-classical-op "CLASSICAL-LESS-THAN" a b c)) + ((LeOp a b c) + (ternary-classical-op "CLASSICAL-LESS-EQUAL" a b c)))) + + (declare raw-ref-arg (MaybeFormal Ref -> raw:RefArg)) + (define (raw-ref-arg ja) + (match ja + ((Formal name) + (lisp raw:RefArg (name) + (quil:formal name))) + ((Actual (Ref name loc)) + (lisp raw:RefArg (name loc) + (quil:mref name loc))))) + + (declare instr-to-raw (Instruction :num -> raw:Instruction)) + (define (instr-to-raw instr) + (match instr + ((ApplyGate g) (gate-to-raw g)) + + ((Include name) + (lisp raw:Instruction (name) + (cl:make-instance 'quil:include :pathname name))) + + ((Pragma pstring) + (lisp raw:Instruction (pstring) + (quil::parse-pragma + (quil::tokenize + (cl:with-output-to-string (out) + (cl:write-string "PRAGMA ") + (cl:write-string pstring)))))) + + ((Memory name type length sharing offsets) + (lisp raw:instruction (name type length sharing offsets) + (quil:make-memory-descriptor + :name name + :type (raw-quil-type type) + :length length + :sharing-parent sharing + :sharing-offset-alist + (cl:loop :for offset :in offsets + :collect (cl:cons + (raw-quil-type (offset-type offset)) + (offset-amount offset)))))) + + ((GateDefinition name gdef) + (raw-gate-def name gdef)) + + ((CircuitDefinition name params args body) + (let ((instrs (map instr-to-raw body))) + (lisp raw:Instruction (name params args instrs) + (cl:make-instance 'quil:circuit-definition + :name name + :parameters (cl:mapcar 'quil:param params) + :arguments (cl:mapcar 'quil:formal args) + :body instrs)))) + + ((ApplyOp op) + (raw-classical-op op)) + + ((Label l) + (lisp raw:Instruction (l) + (cl:make-instance 'quil:jump-target + :label (quil:label l)))) + + ((Jump l) + (lisp raw:Instruction (l) + (cl:make-instance 'quil:unconditional-jump + :label (quil:label l)))) + + ((JumpWhen l a) + (lisp raw:Instruction (l a) + (cl:make-instance 'quil:jump-when + :label (quil:label l) + :address (raw-ref-arg a)))) + + ((JumpUnless l a) + (lisp raw:Instruction (l a) + (cl:make-instance 'quil:jump-unless + :label (quil:label l) + :address (raw-ref-arg a)))) + + ((Noop) + (lisp raw:Instruction () + (cl:make-instance 'quil:no-operation))) + + ((Halt) + (lisp raw:Instruction () + (cl:make-instance 'quil:halt))) + + + ((Wait) + (lisp raw:Instruction () + (cl:make-instance 'quil:wait))) + + ((ResetAll) + (lisp raw:Instruction () + (cl:make-instance 'quil:reset))) + + ((Reset qb) + (let ((qb* (arg-to-raw qb))) + (lisp raw:Instruction (qb*) + (cl:make-instance 'quil:reset-qubit :target qb*)))) + + ((Measure qb loc) + (let ((qb* (arg-to-raw qb)) + (loc* (raw-ref-arg loc))) + (lisp raw:Instruction (qb* loc*) + (cl:make-instance 'quil:measure :address loc* :qubit qb*)))) + + + ((MeasureDiscard qb) + (let ((qb* (arg-to-raw qb))) + (lisp raw:Instruction (qb*) + (cl:make-instance 'quil:measure-discard :qubit qb*)))))) + + (declare gate-to-raw ((Gate :num) -> raw:Instruction)) + (define (gate-to-raw g) + (match g + ((Gate name params args) + (raw-gate-application name params args)) + ((I a) + (raw-gate-application "I" nil (make-list a))) + ((X a) + (raw-gate-application "X" nil (make-list a))) + ((Y a) + (raw-gate-application "Y" nil (make-list a))) + ((Z a) + (raw-gate-application "Z" nil (make-list a))) + ((H a) + (raw-gate-application "H" nil (make-list a))) + ((S a) + (raw-gate-application "S" nil (make-list a))) + ((T a) + (raw-gate-application "T" nil (make-list a))) + ((RX e a) + (raw-gate-application "RX" (make-list e) (make-list a))) + ((RY e a) + (raw-gate-application "RY" (make-list e) (make-list a))) + ((RZ e a) + (raw-gate-application "RZ" (make-list e) (make-list a))) + ((PHASE e a) + (raw-gate-application "PHASE" (make-list e) (make-list a))) + ((CNOT a b) + (raw-gate-application "CNOT" nil (make-list a b))) + ((CZ a b) + (raw-gate-application "CZ" nil (make-list a b))) + ((SWAP a b) + (raw-gate-application "SWAP" nil (make-list a b))) + ((ISWAP a b) + (raw-gate-application "ISWAP" nil (make-list a b))) + ((SQISWAP a b) + (raw-gate-application "SQISWAP" nil (make-list a b))) + ((CSWAP a b c) + (raw-gate-application "CSWAP" nil (make-list a b c))) + ((CCNOT a b c) + (raw-gate-application "CCNOT" nil (make-list a b c))) + ((PSWAP e a b) + (raw-gate-application "PSWAP" (make-list e) (make-list a b))) + ((PISWAP e a b) + (raw-gate-application "PISWAP" (make-list e) (make-list a b))) + ((XY e a b) + (raw-gate-application "XY" (make-list e) (make-list a b))) + ((CAN alpha beta gamma a b) + (raw-gate-application "CAN" + (make-list alpha beta gamma) + (make-list a b))) + ((BLOCH a b c q) + (raw-gate-application "BLOCH" (make-list a b c) (make-list q))) + ((DAGGER g) + (let ((gapp (gate-to-raw g))) + (lisp raw:Instruction (gapp) + (cl:setf (quil:application-operator gapp) + (quil:dagger-operator (quil:application-operator gapp))) + gapp))) + ((CONTROLLED q g) + (let ((gapp (gate-to-raw g)) + (rawq (arg-to-raw q))) + (lisp raw:Instruction (gapp rawq) + (cl:setf (quil:application-operator gapp) + (quil:controlled-operator (quil:application-operator gapp))) + (cl:setf (quil:application-arguments gapp) + (cons rawq + (quil:application-arguments gapp))) + gapp))) + + ((FORKED ctl ps g) + (let ((gapp (gate-to-raw g)) + (rawctl (arg-to-raw ctl)) + (rawps (map expr-to-raw ps))) + (lisp raw:Instruction (gapp rawctl rawps) + (cl:setf (quil:application-operator gapp) + (quil:forked-operator (quil:application-operator gapp))) + (cl:setf (quil:application-parameters gapp) + (cl:nconc rawps (quil:application-parameters gapp))) + (cl:setf (quil:application-arguments gapp) + (cons rawctl (quil:application-arguments gapp))) + gapp))))) + + + (declare build-resolved-program (List (Instruction :num) -> raw:Program)) + (define (build-resolved-program instrs) + (let ((raw-instrs (map instr-to-raw instrs))) + (lisp raw:Program (raw-instrs) + (cl:let ((pp (quil:resolve-objects + (quil::raw-quil-to-unresolved-program + raw-instrs)))) + (cl:dolist (xform quil::*standard-post-parsing-transforms*) + (cl:setf pp (quil:transform xform pp))) + pp)))) + + ;; end module + ) + + + + + + From f99a2ccf1bd99a836ad20486053c55faf1fad5f4 Mon Sep 17 00:00:00 2001 From: Colin O'Keefe Date: Tue, 24 Sep 2024 14:30:42 -0700 Subject: [PATCH 2/7] Reorganize for cleaner modularity --- src/coalton/ast/raw.lisp | 469 ++++++++++++++++++++++++++- src/coalton/ast/unresolved.lisp | 541 ++++++-------------------------- 2 files changed, 549 insertions(+), 461 deletions(-) diff --git a/src/coalton/ast/raw.lisp b/src/coalton/ast/raw.lisp index 59cab9f2..7c8f62af 100644 --- a/src/coalton/ast/raw.lisp +++ b/src/coalton/ast/raw.lisp @@ -1,24 +1,129 @@ (defpackage #:quil/ast/raw (:use #:coalton) (:documentation "Native Cl-QUIL and CL-QUIL.FRONTEND Types") - (:export - #:Program - #:Instruction - #:QubitArg - #:Param - #:MRef - #:RefArg - #:QuilType)) + (:import-from #:coalton-library/classes #:map) + (:local-nicknames + (#:quil #:cl-quil.frontend) + (#:ast #:quil/ast/unresolved))) (in-package #:quil/ast/raw) (named-readtables:in-readtable coalton:coalton) +;;; HELPERS TO COPE WITH RESOLVING ARITHMETIC EXPRESSIONS TO THEIR +;;; "RAW" CL-QUIL REPRESENTATIONS + +(cl:defun get-expr-params (expr) + "Helper function. Returns a list suitable for filling the PARAMETERS +slot of a DELAYED-EXPRESSION instance." + (cl:etypecase expr + (cl:null cl:nil) + (quil:param (cl:list expr)) + (quil:constant cl:nil) + (quil:delayed-expression + (quil:delayed-expression-params expr)))) + +(cl:defun get-expr-lambda-params (expr) + "Helper function. Returns a list of symbols suitable for filling the +LAMBDA-PARAMETERS slot of a DELAYED-EXPRESSION instance" + (cl:etypecase expr + (cl:null cl:nil) + (quil:param (cl:list (cl:make-symbol (quil:param-name expr)))) + (quil:constant cl:nil) + (quil:delayed-expression + (quil:delayed-expression-lambda-params expr)))) + +(cl:defun get-expr-exprs (expr) + "Helper function, returns a value that can appear as a +sub-expression (a SEXP) in a DELAYED-EXPRESSIONS instance's EXPRESSION +slot." + (cl:etypecase expr + (cl:null cl:nil) + (quil:param (cl:make-symbol (quil:param-name expr))) + (quil:constant (quil:constant-value expr)) + (quil:delayed-expression + (quil:delayed-expression-expression expr)))) + +(cl:defmacro combine-params (str arg1 cl:&optional arg2) + "Generates a form to produce a DELAYED-EXPRESSION out of the values of +forms ARG1 and ARG2, which may be anything that can appear in a +parameter postion of a gate application." + (cl:let* ((var1 (cl:gensym "VAR")) + (var2 (cl:gensym "VAR")) + (vars (cl:list var1 var2)) + (new-params (cl:gensym "PARAMS")) + (new-lambda-params (cl:gensym "LAMBDAPARAMS")) + (new-expression (cl:gensym "EXPR")) + (op (cl:gensym "OP"))) + `(let ((,var1 (expr-to-raw ,arg1)) + (,var2 ,(cl:if arg2 + `(expr-to-raw ,arg2) + `(lisp Param () cl:nil)))) + (lisp Param ,(cl:if (cl:stringp str) vars (cl:cons str vars)) + (cl:let* ((,op (cl:intern (cl:string-upcase ,str) :common-lisp)) + (,new-params + (cl:union (get-expr-params ,var1) + (get-expr-params ,var2) + :test 'cl:equalp)) + (,new-lambda-params + (cl:union (get-expr-lambda-params ,var1) + (get-expr-lambda-params ,var2) + :test 'cl:string=)) + (,new-expression + (cl:list* ,op + (get-expr-exprs ,var1) + (cl:if ,var2 + (cl:list + (get-expr-exprs ,var2)) + cl:nil)))) + (quil:make-delayed-expression + ,new-params ,new-lambda-params ,new-expression)))))) + + +;; HELPER MACROS TO INSTANTIATE CLASSICAL MEMORY OPERATION INSTRUCTIONS + +(cl:defmacro unary-classical-op (name ref) + (cl:let ((rawvar (cl:gensym))) + `(let ((,rawvar (raw-ref-arg ,ref))) + (lisp Instruction (,rawvar) + (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) + :target ,rawvar))))) + +(cl:defmacro binary-classical-op (name left right) + (cl:let ((lvar (cl:gensym)) + (rvar (cl:gensym))) + `(let ((,lvar (raw-ref-arg ,left)) + (,rvar (raw-ref-arg ,right))) + (lisp Instruction (,lvar ,rvar) + (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) + :left ,lvar :right ,rvar))))) + +(cl:defmacro ternary-classical-op (name target left right) + (cl:let ((tvar (cl:gensym)) + (lvar (cl:gensym)) + (rvar (cl:gensym))) + `(let ((,tvar (raw-ref-arg ,target)) + (,lvar (raw-ref-arg ,left)) + (,rvar (raw-ref-arg ,right))) + (lisp Instruction (,tvar ,lvar ,rvar) + (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) + :left ,lvar :right ,rvar :target ,tvar))))) + + + (coalton-toplevel (repr :native cl-quil:quil-type) (define-type QuilType) + (declare raw-quil-type (ast:QuilType -> QuilType)) + (define (raw-quil-type qt) + (match qt + ((ast:QuilBit) (lisp QuilType () quil:quil-bit)) + ((ast:QuilOctet) (lisp QuilType () quil:quil-octet)) + ((ast:QuilInteger) (lisp QuilType () quil:quil-integer)) + ((ast:QuilReal) (lisp QuilType () quil:quil-real)))) + (repr :native cl-quil:parsed-program) (define-type Program) @@ -31,6 +136,11 @@ (repr :native cl-quil:memory-ref) (define-type MRef) + (declare ref-to-raw (ast:Ref -> Mref)) + (define (ref-to-raw (ast:Ref name loc)) + (lisp Mref (name loc) + (quil:mref name loc))) + (repr :native (cl:or cl-quil:param cl-quil.frontend:delayed-expression cl-quil:constant cl:null)) @@ -41,4 +151,345 @@ cl-quil:jump-target cl-quil:gate-definition cl-quil:circuit-definition)) - (define-type Instruction)) + (define-type Instruction) + + ;; If non-literal numbertypes are supported, this should be altered + ;; to be something like (real :num, complex :num => ..) + ;; and the Const case be handled to interperet the :num to a type + ;; that quilc can already handle + (declare expr-to-raw (ast:Expr :num -> Param)) + (define (expr-to-raw e) + (match e + ((ast:Add e1 e2) (combine-params "+" e1 e2)) + + ((ast:Sub e1 e2) (combine-params "-" e1 e2)) + + ((ast:Mul e1 e2) (combine-params "*" e1 e2)) + + ((ast:Div e1 e2) (combine-params "/" e1 e2)) + + ((ast:Pow e1 e2) (combine-params "EXPT" e1 e2)) + + ((ast:Neg e1) (combine-params "-" e1)) + + ((ast:Const e) + (lisp Param (e) + (quil:constant e))) + + ((ast:RefExpr rf) + (let ((rr (ref-to-raw rf))) + (lisp Param (rr) + (quil:make-delayed-expression cl:nil cl:nil rr)))) + + ((ast:Var name) + (lisp Param (name) + (quil:param name))) + + ((ast:Call name e) + (combine-params name e)))) + + (declare arg-to-raw ((ast:MaybeFormal Ufix) -> QubitArg)) + (define (arg-to-raw a) + (match a + ((ast:Actual qb) (lisp QubitArg (qb) (quil:qubit qb))) + ((ast:Formal name) (lisp QubitArg (name) (quil:formal name))))) + + (declare raw-gate-application + (String -> (List (ast:Expr :num)) -> (List (ast:MaybeFormal Ufix)) -> Instruction)) + (define (raw-gate-application name params args) + (let ((params* (map expr-to-raw params)) + (args* (map arg-to-raw args))) + (lisp Instruction (name params* args*) + (cl:make-instance 'quil:unresolved-application + :operator (quil:named-operator name) + :parameters params* + :arguments args*)))) + + + (declare raw-classical-op (ast:ClassicalOperation -> Instruction)) + (define (raw-classical-op op) + (match op + ((ast:NegOp r) + (unary-classical-op "CLASSICAL-NEGATE" r)) + ((ast:NotOp r) + (unary-classical-op "CLASSICAL-NOT" r)) + + ((ast:MoveOp a b) + (binary-classical-op "CLASSICAL-MOVE" a b)) + ((ast:ExchangeOp a b) + (binary-classical-op "CLASSICAL-EXCHANGE" a b)) + ((ast:ConvertOp a b) + (binary-classical-op "CLASSICAL-CONVERT" a b)) + ((ast:AndOp a b) + (binary-classical-op "CLASSICAL-AND" a b)) + ((ast:IOrOp a b) + (binary-classical-op "CLASSICAL-INCLUSIVE-OR" a b)) + ((ast:XOrOp a b) + (binary-classical-op "CLASSICAL-EXCLUSIVE-OR" a b)) + ((ast:AddOp a b) + (binary-classical-op "CLASSICAL-ADDITION" a b)) + ((ast:SubOp a b) + (binary-classical-op "CLASSICAL-SUBTRACTION" a b)) + ((ast:MulOp a b) + (binary-classical-op "CLASSICAL-MULTIPLICATION" a b)) + ((ast:DivOp a b) + (binary-classical-op "CLASSICAL-DIVISION" a b)) + + ((ast:LoadOp a b c) + (ternary-classical-op "CLASSICAL-LOAD" a b c)) + ((ast:StoreOp a b c) + (ternary-classical-op "CLASSICAL-STORE" a b c)) + ((ast:EqOp a b c) + (ternary-classical-op "CLASSICAL-EQUALITY" a b c)) + ((ast:GtOp a b c) + (ternary-classical-op "CLASSICAL-GREATER-THAN" a b c)) + ((ast:GeOp a b c) + (ternary-classical-op "CLASSICAL-GREATER-EQUAL" a b c)) + ((ast:LtOp a b c) + (ternary-classical-op "CLASSICAL-LESS-THAN" a b c)) + ((ast:LeOp a b c) + (ternary-classical-op "CLASSICAL-LESS-EQUAL" a b c)))) + + (declare raw-gate-def (String -> (ast:GateDef :num) -> Instruction)) + (define (raw-gate-def name gdef) + (match gdef + ((ast:PermuationGateDef vals) + (lisp Instruction (name vals) + (cl:make-instance 'quil:permutation-gate-definition + :name name :permutation vals :context cl:nil))) + + ((ast:ParameterizedGateDef params exprs) + (let ((exprs* (map expr-to-raw exprs))) + (lisp Instruction (name params exprs*) + (cl:make-instance 'quil:parameterized-gate-definition + :name name + :entries (cl:mapcar 'get-expr-exprs exprs*) + :parameters (cl:mapcar 'cl:make-symbol params))))) + + ((ast:StaticGateDef entries) + (lisp Instruction (name entries) + (cl:make-instance 'quil:static-gate-definition + :name name + :entries entries))) + + ((ast:PauliSumGateDef terms params args) + (lisp Instruction (name terms params args) + (cl:make-instance 'quil:exp-pauli-sum-gate-definition + :name name + :arguments (cl:mapcar #'quil:formal args) + :parameters (cl:mapcar 'cl:make-symbol params) + :terms (cl:loop :for term :in terms + :collect (quil:make-pauli-term + :pauli-word (ast:pauli-term-word term) + :prefactor (ast:pauli-term-prefactor term) + :arguments (cl:mapcar #'quil:formal (ast:pauli-term-arguments term))))))))) + + + (declare raw-ref-arg (ast:MaybeFormal ast:Ref -> RefArg)) + (define (raw-ref-arg ja) + (match ja + ((ast:Formal name) + (lisp RefArg (name) + (quil:formal name))) + ((ast:Actual (ast:Ref name loc)) + (lisp RefArg (name loc) + (quil:mref name loc))))) + + (declare instr-to-raw (ast:Instruction :num -> Instruction)) + (define (instr-to-raw instr) + (match instr + ((ast:ApplyGate g) (gate-to-raw g)) + + ((ast:Include name) + (lisp Instruction (name) + (cl:make-instance 'quil:include :pathname name))) + + ((ast:Pragma pstring) + (lisp Instruction (pstring) + (quil::parse-pragma + (quil::tokenize + (cl:with-output-to-string (out) + (cl:write-string "PRAGMA ") + (cl:write-string pstring)))))) + + ((ast:Memory name type length sharing offsets) + (lisp instruction (name type length sharing offsets) + (quil:make-memory-descriptor + :name name + :type (raw-quil-type type) + :length length + :sharing-parent sharing + :sharing-offset-alist + (cl:loop :for offset :in offsets + :collect (cl:cons + (raw-quil-type (ast:offset-type offset)) + (ast:offset-amount offset)))))) + + ((ast:GateDefinition name gdef) + (raw-gate-def name gdef)) + + ((ast:CircuitDefinition name params args body) + (let ((instrs (map instr-to-raw body))) + (lisp Instruction (name params args instrs) + (cl:make-instance 'quil:circuit-definition + :name name + :parameters (cl:mapcar 'quil:param params) + :arguments (cl:mapcar 'quil:formal args) + :body instrs)))) + + ((ast:ApplyOp op) + (raw-classical-op op)) + + ((ast:Label l) + (lisp Instruction (l) + (cl:make-instance 'quil:jump-target + :label (quil:label l)))) + + ((ast:Jump l) + (lisp Instruction (l) + (cl:make-instance 'quil:unconditional-jump + :label (quil:label l)))) + + ((ast:JumpWhen l a) + (lisp Instruction (l a) + (cl:make-instance 'quil:jump-when + :label (quil:label l) + :address (raw-ref-arg a)))) + + ((ast:JumpUnless l a) + (lisp Instruction (l a) + (cl:make-instance 'quil:jump-unless + :label (quil:label l) + :address (raw-ref-arg a)))) + + ((ast:Noop) + (lisp Instruction () + (cl:make-instance 'quil:no-operation))) + + ((ast:Halt) + (lisp Instruction () + (cl:make-instance 'quil:halt))) + + + ((ast:Wait) + (lisp Instruction () + (cl:make-instance 'quil:wait))) + + ((ast:ResetAll) + (lisp Instruction () + (cl:make-instance 'quil:reset))) + + ((ast:Reset qb) + (let ((qb* (arg-to-raw qb))) + (lisp Instruction (qb*) + (cl:make-instance 'quil:reset-qubit :target qb*)))) + + ((ast:Measure qb loc) + (let ((qb* (arg-to-raw qb)) + (loc* (raw-ref-arg loc))) + (lisp Instruction (qb* loc*) + (cl:make-instance 'quil:measure :address loc* :qubit qb*)))) + + + ((ast:MeasureDiscard qb) + (let ((qb* (arg-to-raw qb))) + (lisp Instruction (qb*) + (cl:make-instance 'quil:measure-discard :qubit qb*)))))) + + (declare gate-to-raw (ast:Gate :num -> Instruction)) + (define (gate-to-raw g) + (match g + ((ast:Gate name params args) + (raw-gate-application name params args)) + ((ast:I a) + (raw-gate-application "I" nil (make-list a))) + ((ast:X a) + (raw-gate-application "X" nil (make-list a))) + ((ast:Y a) + (raw-gate-application "Y" nil (make-list a))) + ((ast:Z a) + (raw-gate-application "Z" nil (make-list a))) + ((ast:H a) + (raw-gate-application "H" nil (make-list a))) + ((ast:S a) + (raw-gate-application "S" nil (make-list a))) + ((ast:T a) + (raw-gate-application "T" nil (make-list a))) + ((ast:RX e a) + (raw-gate-application "RX" (make-list e) (make-list a))) + ((ast:RY e a) + (raw-gate-application "RY" (make-list e) (make-list a))) + ((ast:RZ e a) + (raw-gate-application "RZ" (make-list e) (make-list a))) + ((ast:PHASE e a) + (raw-gate-application "PHASE" (make-list e) (make-list a))) + ((ast:CNOT a b) + (raw-gate-application "CNOT" nil (make-list a b))) + ((ast:CZ a b) + (raw-gate-application "CZ" nil (make-list a b))) + ((ast:SWAP a b) + (raw-gate-application "SWAP" nil (make-list a b))) + ((ast:ISWAP a b) + (raw-gate-application "ISWAP" nil (make-list a b))) + ((ast:SQISWAP a b) + (raw-gate-application "SQISWAP" nil (make-list a b))) + ((ast:CSWAP a b c) + (raw-gate-application "CSWAP" nil (make-list a b c))) + ((ast:CCNOT a b c) + (raw-gate-application "CCNOT" nil (make-list a b c))) + ((ast:PSWAP e a b) + (raw-gate-application "PSWAP" (make-list e) (make-list a b))) + ((ast:PISWAP e a b) + (raw-gate-application "PISWAP" (make-list e) (make-list a b))) + ((ast:XY e a b) + (raw-gate-application "XY" (make-list e) (make-list a b))) + ((ast:CAN alpha beta gamma a b) + (raw-gate-application "CAN" + (make-list alpha beta gamma) + (make-list a b))) + ((ast:BLOCH a b c q) + (raw-gate-application "BLOCH" (make-list a b c) (make-list q))) + ((ast:DAGGER g) + (let ((gapp (gate-to-raw g))) + (lisp Instruction (gapp) + (cl:setf (quil:application-operator gapp) + (quil:dagger-operator (quil:application-operator gapp))) + gapp))) + ((ast:CONTROLLED q g) + (let ((gapp (gate-to-raw g)) + (rawq (arg-to-raw q))) + (lisp Instruction (gapp rawq) + (cl:setf (quil:application-operator gapp) + (quil:controlled-operator (quil:application-operator gapp))) + (cl:setf (quil:application-arguments gapp) + (cons rawq + (quil:application-arguments gapp))) + gapp))) + + ((ast:FORKED ctl ps g) + (let ((gapp (gate-to-raw g)) + (rawctl (arg-to-raw ctl)) + (rawps (map expr-to-raw ps))) + (lisp Instruction (gapp rawctl rawps) + (cl:setf (quil:application-operator gapp) + (quil:forked-operator (quil:application-operator gapp))) + (cl:setf (quil:application-parameters gapp) + (cl:nconc rawps (quil:application-parameters gapp))) + (cl:setf (quil:application-arguments gapp) + (cons rawctl (quil:application-arguments gapp))) + gapp))))) + + + (declare build-resolved-program (List (ast:Instruction :num) -> Program)) + (define (build-resolved-program instrs) + (let ((raw-instrs (map instr-to-raw instrs))) + (lisp Program (raw-instrs) + (cl:let ((pp (quil:resolve-objects + (quil::raw-quil-to-unresolved-program + raw-instrs)))) + (cl:dolist (xform quil::*standard-post-parsing-transforms*) + (cl:setf pp (quil:transform xform pp))) + pp)))) + + ;;eof + ) diff --git a/src/coalton/ast/unresolved.lisp b/src/coalton/ast/unresolved.lisp index e9c8514e..757d19cb 100644 --- a/src/coalton/ast/unresolved.lisp +++ b/src/coalton/ast/unresolved.lisp @@ -1,116 +1,100 @@ (defpackage #:quil/ast/unresolved (:use #:coalton) - (:import-from #:coalton-library/classes #:map) (:import-from #:coalton) - (:local-nicknames - (#:quil #:cl-quil.frontend) - (#:complex #:coalton-library/math/complex) - (#:raw #:quil/ast/raw))) + (:export + #:Ref + #:Add + #:Sub + #:Mul + #:Div + #:Pow + #:Neg + #:Const + #:Call + #:Var + #:RefExpr + #:Expr + + #:MaybeFormal + #:Actual + #:Formal + + #:Gate + #:I #:X #:Y #:Z #:H #:S #:T + #:RX #:RY #:RZ #:Phase + #:CNOT #:CZ #:SWAP #:ISWAP #:SQISWAP + #:CSWAP #:CCNOT + #:PSWAP #:PISWAP #:XY + #:CAN + #:BLOCH + #:DAGGER + #:CONTROLLED + #:FORKED + + #:QuilType + #:QuilBit #:QuilOctet #:QuilInteger #:QuilReal + + #:MemOffset + #:offset-type #:offset-amount + + #:PauliTerm + #:pauli-term-word + #:pauli-term-prefactor + #:pauli-term-arguments + + #:GateDef + #:PermuationGateDef + #:StaticGateDef + #:ParameterizedGateDef + #:PauliSumGateDef + + #:ClassicalOperation + #:NotOp + #:NegOp + #:MoveOp + #:ExchangeOp + #:ConvertOp + #:AndOp + #:IOrOp + #:XOrOp + #:AddOp + #:SubOp + #:MulOp + #:DivOp + #:LoadOp + #:StoreOp + #:EqOp + #:GtOp + #:GeOp + #:LtOp + #:LeOp + + #:Instruction + #:ApplyGate + #:Include + #:Pragma + #:Memory + #:GateDefinition + #:CircuitDefinition + #:Label + #:ApplyOp + #:Jump + #:JumpWhen + #:JumpUnless + #:Noop + #:Halt + #:Wait + #:ResetAll + #:Reset + #:Measure + #:MeasureDiscard)) + + (in-package #:quil/ast/unresolved) (named-readtables:in-readtable coalton:coalton) - -;;; HELPERS TO COPE WITH RESOLVING ARITHMETIC EXPRESSIONS TO THEIR -;;; "RAW" CL-QUIL REPRESENTATIONS - -(cl:defun get-expr-params (expr) - "Helper function. Returns a list suitable for filling the PARAMETERS -slot of a DELAYED-EXPRESSION instance." - (cl:etypecase expr - (cl:null cl:nil) - (quil:param (cl:list expr)) - (quil:constant cl:nil) - (quil:delayed-expression - (quil:delayed-expression-params expr)))) - -(cl:defun get-expr-lambda-params (expr) - "Helper function. Returns a list of symbols suitable for filling the -LAMBDA-PARAMETERS slot of a DELAYED-EXPRESSION instance" - (cl:etypecase expr - (cl:null cl:nil) - (quil:param (cl:list (cl:make-symbol (quil:param-name expr)))) - (quil:constant cl:nil) - (quil:delayed-expression - (quil:delayed-expression-lambda-params expr)))) - -(cl:defun get-expr-exprs (expr) - "Helper function, returns a value that can appear as a -sub-expression (a SEXP) in a DELAYED-EXPRESSIONS instance's EXPRESSION -slot." - (cl:etypecase expr - (cl:null cl:nil) - (quil:param (cl:make-symbol (quil:param-name expr))) - (quil:constant (quil:constant-value expr)) - (quil:delayed-expression - (quil:delayed-expression-expression expr)))) - -(cl:defmacro combine-params (str arg1 cl:&optional arg2) - "Generates a form to produce a DELAYED-EXPRESSION out of the values of -forms ARG1 and ARG2, which may be anything that can appear in a -parameter postion of a gate application." - (cl:let* ((var1 (cl:gensym "VAR")) - (var2 (cl:gensym "VAR")) - (vars (cl:list var1 var2)) - (new-params (cl:gensym "PARAMS")) - (new-lambda-params (cl:gensym "LAMBDAPARAMS")) - (new-expression (cl:gensym "EXPR")) - (op (cl:gensym "OP"))) - `(let ((,var1 (expr-to-raw ,arg1)) - (,var2 ,(cl:if arg2 - `(expr-to-raw ,arg2) - `(lisp raw:Param () cl:nil)))) - (lisp raw:Param ,(cl:if (cl:stringp str) vars (cl:cons str vars)) - (cl:let* ((,op (cl:intern (cl:string-upcase ,str) :common-lisp)) - (,new-params - (cl:union (get-expr-params ,var1) - (get-expr-params ,var2) - :test 'cl:equalp)) - (,new-lambda-params - (cl:union (get-expr-lambda-params ,var1) - (get-expr-lambda-params ,var2) - :test 'cl:string=)) - (,new-expression - (cl:list* ,op - (get-expr-exprs ,var1) - (cl:if ,var2 - (cl:list - (get-expr-exprs ,var2)) - cl:nil)))) - (quil:make-delayed-expression - ,new-params ,new-lambda-params ,new-expression)))))) - - -;; HELPER MACROS TO INSTANTIATE CLASSICAL MEMORY OPERATION INSTRUCTIONS - -(cl:defmacro unary-classical-op (name ref) - (cl:let ((rawvar (cl:gensym))) - `(let ((,rawvar (raw-ref-arg ,ref))) - (lisp raw:Instruction (,rawvar) - (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) - :target ,rawvar))))) - -(cl:defmacro binary-classical-op (name left right) - (cl:let ((lvar (cl:gensym)) - (rvar (cl:gensym))) - `(let ((,lvar (raw-ref-arg ,left)) - (,rvar (raw-ref-arg ,right))) - (lisp raw:Instruction (,lvar ,rvar) - (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) - :left ,lvar :right ,rvar))))) - -(cl:defmacro ternary-classical-op (name target left right) - (cl:let ((tvar (cl:gensym)) - (lvar (cl:gensym)) - (rvar (cl:gensym))) - `(let ((,tvar (raw-ref-arg ,target)) - (,lvar (raw-ref-arg ,left)) - (,rvar (raw-ref-arg ,right))) - (lisp raw:Instruction (,tvar ,lvar ,rvar) - (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) - :left ,lvar :right ,rvar :target ,tvar))))) - (coalton-toplevel (define-type Ref @@ -119,11 +103,6 @@ parameter postion of a gate application." Ufix ; position )) - (declare ref-to-raw (Ref -> raw:Mref)) - (define (ref-to-raw (Ref name loc)) - (lisp raw:Mref (name loc) - (quil:mref name loc))) - (define-type (Expr :num) "Arithmetic expressions appearing in gate application parameter positions and in gate definitions. In the latter case, Memory @@ -196,14 +175,6 @@ represented by a formal name." "A valid data type for Quil memory." QuilBit QuilOctet QuilInteger QuilReal) - (declare raw-quil-type (QuilType -> raw:QuilType)) - (define (raw-quil-type qt) - (match qt - ((QuilBit) (lisp raw:QuilType () quil:quil-bit)) - ((QuilOctet) (lisp raw:QuilType () quil:quil-octet)) - ((QuilInteger) (lisp raw:QuilType () quil:quil-integer)) - ((QuilReal) (lisp raw:QuilType () quil:quil-real)))) - (define-type MemOffset "Used in declaring offsets into shared memory declarations" (MemOffset QuilType Ufix)) @@ -294,340 +265,6 @@ represented by a formal name." (Measure (MaybeFormal Ufix) (MaybeFormal Ref)) (MeasureDiscard (MaybeFormal Ufix))) - ;; If non-literal numbertypes are supported, this should be altered - ;; to be something like (real :num, complex :num => ..) - ;; and the Const case be handled to interperet the :num to a type - ;; that quilc can already handle - (declare expr-to-raw (Expr :num -> raw:Param)) - (define (expr-to-raw e) - (match e - ((Add e1 e2) (combine-params "+" e1 e2)) - - ((Sub e1 e2) (combine-params "-" e1 e2)) - - ((Mul e1 e2) (combine-params "*" e1 e2)) - - ((Div e1 e2) (combine-params "/" e1 e2)) - - ((Pow e1 e2) (combine-params "EXPT" e1 e2)) - - ((Neg e1) (combine-params "-" e1)) - - ((Const e) - (lisp raw:Param (e) - (quil:constant e))) - - ((RefExpr rf) - (let ((rr (ref-to-raw rf))) - (lisp raw:Param (rr) - (quil:make-delayed-expression cl:nil cl:nil rr)))) - - ((Var name) - (lisp raw:Param (name) - (quil:param name))) - - ((Call name e) - (combine-params name e)))) - - (declare arg-to-raw ((MaybeFormal Ufix) -> raw:QubitArg)) - (define (arg-to-raw a) - (match a - ((Actual qb) (lisp raw:QubitArg (qb) (quil:qubit qb))) - ((Formal name) (lisp raw:QubitArg (name) (quil:formal name))))) - - (declare raw-gate-application - (String -> (List (Expr :num)) -> (List (MaybeFormal Ufix)) -> raw:Instruction)) - (define (raw-gate-application name params args) - (let ((params* (map expr-to-raw params)) - (args* (map arg-to-raw args))) - (lisp raw:Instruction (name params* args*) - (cl:make-instance 'quil:unresolved-application - :operator (quil:named-operator name) - :parameters params* - :arguments args*)))) - - (define (raw-gate-def name gdef) - (match gdef - ((PermuationGateDef vals) - (lisp raw:Instruction (name vals) - (cl:make-instance 'quil:permutation-gate-definition - :name name :permutation vals :context cl:nil))) - - ((StaticGateDef entries) - (lisp raw:Instruction (name entries) - (cl:make-instance 'quil:static-gate-definition - :name name - :entries entries))) - - ((ParameterizedGateDef params exprs) - (let ((exprs* (map expr-to-raw exprs))) - (lisp raw:instruction (name params exprs*) - (cl:make-instance 'quil:parameterized-gate-definition - :name name - :entries (cl:mapcar 'get-expr-exprs exprs*) - :parameters (cl:mapcar 'cl:make-symbol params))))) - - ((PauliSumGateDef terms params args) - (lisp raw:Instruction (name terms params args) - (cl:make-instance 'quil:exp-pauli-sum-gate-definition - :name name - :arguments (cl:mapcar #'quil:formal args) - :parameters (cl:mapcar 'cl:make-symbol params) - :terms (cl:loop :for term :in terms - :collect (quil:make-pauli-term - :pauli-word (pauli-term-word term) - :prefactor (pauli-term-prefactor term) - :arguments (cl:mapcar #'quil:formal (pauli-term-arguments term))))))))) - - - (define (raw-classical-op op) - (match op - ((NegOp r) - (unary-classical-op "CLASSICAL-NEGATE" r)) - ((NotOp r) - (unary-classical-op "CLASSICAL-NOT" r)) - - ((MoveOp a b) - (binary-classical-op "CLASSICAL-MOVE" a b)) - ((ExchangeOp a b) - (binary-classical-op "CLASSICAL-EXCHANGE" a b)) - ((ConvertOp a b) - (binary-classical-op "CLASSICAL-CONVERT" a b)) - ((AndOp a b) - (binary-classical-op "CLASSICAL-AND" a b)) - ((IOrOp a b) - (binary-classical-op "CLASSICAL-INCLUSIVE-OR" a b)) - ((XOrOp a b) - (binary-classical-op "CLASSICAL-EXCLUSIVE-OR" a b)) - ((AddOp a b) - (binary-classical-op "CLASSICAL-ADDITION" a b)) - ((SubOp a b) - (binary-classical-op "CLASSICAL-SUBTRACTION" a b)) - ((MulOp a b) - (binary-classical-op "CLASSICAL-MULTIPLICATION" a b)) - ((DivOp a b) - (binary-classical-op "CLASSICAL-DIVISION" a b)) - - ((LoadOp a b c) - (ternary-classical-op "CLASSICAL-LOAD" a b c)) - ((StoreOp a b c) - (ternary-classical-op "CLASSICAL-STORE" a b c)) - ((EqOp a b c) - (ternary-classical-op "CLASSICAL-EQUALITY" a b c)) - ((GtOp a b c) - (ternary-classical-op "CLASSICAL-GREATER-THAN" a b c)) - ((GeOp a b c) - (ternary-classical-op "CLASSICAL-GREATER-EQUAL" a b c)) - ((LtOp a b c) - (ternary-classical-op "CLASSICAL-LESS-THAN" a b c)) - ((LeOp a b c) - (ternary-classical-op "CLASSICAL-LESS-EQUAL" a b c)))) - - (declare raw-ref-arg (MaybeFormal Ref -> raw:RefArg)) - (define (raw-ref-arg ja) - (match ja - ((Formal name) - (lisp raw:RefArg (name) - (quil:formal name))) - ((Actual (Ref name loc)) - (lisp raw:RefArg (name loc) - (quil:mref name loc))))) - - (declare instr-to-raw (Instruction :num -> raw:Instruction)) - (define (instr-to-raw instr) - (match instr - ((ApplyGate g) (gate-to-raw g)) - - ((Include name) - (lisp raw:Instruction (name) - (cl:make-instance 'quil:include :pathname name))) - - ((Pragma pstring) - (lisp raw:Instruction (pstring) - (quil::parse-pragma - (quil::tokenize - (cl:with-output-to-string (out) - (cl:write-string "PRAGMA ") - (cl:write-string pstring)))))) - - ((Memory name type length sharing offsets) - (lisp raw:instruction (name type length sharing offsets) - (quil:make-memory-descriptor - :name name - :type (raw-quil-type type) - :length length - :sharing-parent sharing - :sharing-offset-alist - (cl:loop :for offset :in offsets - :collect (cl:cons - (raw-quil-type (offset-type offset)) - (offset-amount offset)))))) - - ((GateDefinition name gdef) - (raw-gate-def name gdef)) - - ((CircuitDefinition name params args body) - (let ((instrs (map instr-to-raw body))) - (lisp raw:Instruction (name params args instrs) - (cl:make-instance 'quil:circuit-definition - :name name - :parameters (cl:mapcar 'quil:param params) - :arguments (cl:mapcar 'quil:formal args) - :body instrs)))) - - ((ApplyOp op) - (raw-classical-op op)) - - ((Label l) - (lisp raw:Instruction (l) - (cl:make-instance 'quil:jump-target - :label (quil:label l)))) - - ((Jump l) - (lisp raw:Instruction (l) - (cl:make-instance 'quil:unconditional-jump - :label (quil:label l)))) - - ((JumpWhen l a) - (lisp raw:Instruction (l a) - (cl:make-instance 'quil:jump-when - :label (quil:label l) - :address (raw-ref-arg a)))) - - ((JumpUnless l a) - (lisp raw:Instruction (l a) - (cl:make-instance 'quil:jump-unless - :label (quil:label l) - :address (raw-ref-arg a)))) - - ((Noop) - (lisp raw:Instruction () - (cl:make-instance 'quil:no-operation))) - - ((Halt) - (lisp raw:Instruction () - (cl:make-instance 'quil:halt))) - - - ((Wait) - (lisp raw:Instruction () - (cl:make-instance 'quil:wait))) - - ((ResetAll) - (lisp raw:Instruction () - (cl:make-instance 'quil:reset))) - - ((Reset qb) - (let ((qb* (arg-to-raw qb))) - (lisp raw:Instruction (qb*) - (cl:make-instance 'quil:reset-qubit :target qb*)))) - - ((Measure qb loc) - (let ((qb* (arg-to-raw qb)) - (loc* (raw-ref-arg loc))) - (lisp raw:Instruction (qb* loc*) - (cl:make-instance 'quil:measure :address loc* :qubit qb*)))) - - - ((MeasureDiscard qb) - (let ((qb* (arg-to-raw qb))) - (lisp raw:Instruction (qb*) - (cl:make-instance 'quil:measure-discard :qubit qb*)))))) - - (declare gate-to-raw ((Gate :num) -> raw:Instruction)) - (define (gate-to-raw g) - (match g - ((Gate name params args) - (raw-gate-application name params args)) - ((I a) - (raw-gate-application "I" nil (make-list a))) - ((X a) - (raw-gate-application "X" nil (make-list a))) - ((Y a) - (raw-gate-application "Y" nil (make-list a))) - ((Z a) - (raw-gate-application "Z" nil (make-list a))) - ((H a) - (raw-gate-application "H" nil (make-list a))) - ((S a) - (raw-gate-application "S" nil (make-list a))) - ((T a) - (raw-gate-application "T" nil (make-list a))) - ((RX e a) - (raw-gate-application "RX" (make-list e) (make-list a))) - ((RY e a) - (raw-gate-application "RY" (make-list e) (make-list a))) - ((RZ e a) - (raw-gate-application "RZ" (make-list e) (make-list a))) - ((PHASE e a) - (raw-gate-application "PHASE" (make-list e) (make-list a))) - ((CNOT a b) - (raw-gate-application "CNOT" nil (make-list a b))) - ((CZ a b) - (raw-gate-application "CZ" nil (make-list a b))) - ((SWAP a b) - (raw-gate-application "SWAP" nil (make-list a b))) - ((ISWAP a b) - (raw-gate-application "ISWAP" nil (make-list a b))) - ((SQISWAP a b) - (raw-gate-application "SQISWAP" nil (make-list a b))) - ((CSWAP a b c) - (raw-gate-application "CSWAP" nil (make-list a b c))) - ((CCNOT a b c) - (raw-gate-application "CCNOT" nil (make-list a b c))) - ((PSWAP e a b) - (raw-gate-application "PSWAP" (make-list e) (make-list a b))) - ((PISWAP e a b) - (raw-gate-application "PISWAP" (make-list e) (make-list a b))) - ((XY e a b) - (raw-gate-application "XY" (make-list e) (make-list a b))) - ((CAN alpha beta gamma a b) - (raw-gate-application "CAN" - (make-list alpha beta gamma) - (make-list a b))) - ((BLOCH a b c q) - (raw-gate-application "BLOCH" (make-list a b c) (make-list q))) - ((DAGGER g) - (let ((gapp (gate-to-raw g))) - (lisp raw:Instruction (gapp) - (cl:setf (quil:application-operator gapp) - (quil:dagger-operator (quil:application-operator gapp))) - gapp))) - ((CONTROLLED q g) - (let ((gapp (gate-to-raw g)) - (rawq (arg-to-raw q))) - (lisp raw:Instruction (gapp rawq) - (cl:setf (quil:application-operator gapp) - (quil:controlled-operator (quil:application-operator gapp))) - (cl:setf (quil:application-arguments gapp) - (cons rawq - (quil:application-arguments gapp))) - gapp))) - - ((FORKED ctl ps g) - (let ((gapp (gate-to-raw g)) - (rawctl (arg-to-raw ctl)) - (rawps (map expr-to-raw ps))) - (lisp raw:Instruction (gapp rawctl rawps) - (cl:setf (quil:application-operator gapp) - (quil:forked-operator (quil:application-operator gapp))) - (cl:setf (quil:application-parameters gapp) - (cl:nconc rawps (quil:application-parameters gapp))) - (cl:setf (quil:application-arguments gapp) - (cons rawctl (quil:application-arguments gapp))) - gapp))))) - - - (declare build-resolved-program (List (Instruction :num) -> raw:Program)) - (define (build-resolved-program instrs) - (let ((raw-instrs (map instr-to-raw instrs))) - (lisp raw:Program (raw-instrs) - (cl:let ((pp (quil:resolve-objects - (quil::raw-quil-to-unresolved-program - raw-instrs)))) - (cl:dolist (xform quil::*standard-post-parsing-transforms*) - (cl:setf pp (quil:transform xform pp))) - pp)))) ;; end module ) From 183205a639e54e3f1601dcb9a887c387b9b877fb Mon Sep 17 00:00:00 2001 From: Colin O'Keefe Date: Tue, 24 Sep 2024 15:59:37 -0700 Subject: [PATCH 3/7] cleaning --- src/coalton/ast/unresolved.lisp | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/coalton/ast/unresolved.lisp b/src/coalton/ast/unresolved.lisp index 757d19cb..3141df32 100644 --- a/src/coalton/ast/unresolved.lisp +++ b/src/coalton/ast/unresolved.lisp @@ -120,7 +120,7 @@ (define-type (MaybeFormal :t) "A wrapper type representing a value which may in some contexts be -represented by a formal name." + represented by a formal name." (Actual :t) (Formal String)) @@ -183,9 +183,9 @@ represented by a formal name." (define (offset-amount (MemOffset _ amount)) amount) (define-type (PauliTerm :num) - (PauliTerm String ; pauli word, string of pauli gate names X,Y,Z,I - :num ; prefactor - (List String))) ; arguments + (PauliTerm String ; pauli word, string of pauli gate names X,Y,Z,I + :num ; prefactor + (List String))) ; arguments (define (pauli-term-word (PauliTerm word _ _)) word) (define (pauli-term-prefactor (PauliTerm _ pf _)) pf) @@ -264,8 +264,6 @@ represented by a formal name." (Measure (MaybeFormal Ufix) (MaybeFormal Ref)) (MeasureDiscard (MaybeFormal Ufix))) - - ;; end module ) From 8f48bcde9e3a2a4cbff7f89bc6b079997758e03e Mon Sep 17 00:00:00 2001 From: Colin O'Keefe Date: Wed, 25 Sep 2024 15:53:20 -0700 Subject: [PATCH 4/7] Modularity refinements; more explicit types the introduction of the macro module includes a subeset of instructions from the unresolved module. macro instrutions can accept formal arguments. They were made in order to distinguish instructions that can appear within DEFCIRCUITS from those that appear in executable code. Classical instructions have also been given a numeric type argument --- cl-quil.asd | 14 + src/coalton/ast/classical.lisp | 60 +++ src/coalton/ast/expression.lisp | 35 ++ src/coalton/ast/gate.lisp | 84 ++++ src/coalton/ast/macro.lisp | 67 +++ src/coalton/ast/memory.lisp | 63 +++ src/coalton/ast/native.lisp | 753 ++++++++++++++++++++++++++++++++ src/coalton/ast/unresolved.lisp | 215 ++------- 8 files changed, 1104 insertions(+), 187 deletions(-) create mode 100644 src/coalton/ast/classical.lisp create mode 100644 src/coalton/ast/expression.lisp create mode 100644 src/coalton/ast/gate.lisp create mode 100644 src/coalton/ast/macro.lisp create mode 100644 src/coalton/ast/memory.lisp create mode 100644 src/coalton/ast/native.lisp diff --git a/cl-quil.asd b/cl-quil.asd index e5f814d5..7dcc74c9 100644 --- a/cl-quil.asd +++ b/cl-quil.asd @@ -163,6 +163,20 @@ (:file "print-program") (:file "initialize-standard-gates"))) +(asdf:defsystem #:coalton-quil/ast + :description "Coalton implementation cl-quil/ast" + :depends-on (#:cl-quil #:coalton) + :pathname "src/coalton/ast/" + :serial t + :components ((:file "memory") + (:file "expression") + (:file "classical") + (:file "gate") + (:file "macro") + (:file "unresolved") + (:file "native"))) + + (asdf:defsystem #:cl-quil/chip-library :description "Holds definitions for various chip ISAs." :license "Apache License 2.0 (See LICENSE.txt)" diff --git a/src/coalton/ast/classical.lisp b/src/coalton/ast/classical.lisp new file mode 100644 index 00000000..2d6f5d60 --- /dev/null +++ b/src/coalton/ast/classical.lisp @@ -0,0 +1,60 @@ +(defpackage #:quil/ast/classical + (:use #:coalton) + (:shadow #:And) + (:export + #:Arg + #:Ref + #:Const + #:Operation + #:Not + #:Neg + #:Move + #:Exchange + #:Convert + #:And + #:IOr + #:XOr + #:Add + #:Sub + #:Mul + #:Div + #:Load + #:Store + #:Eq + #:Gt + #:Ge + #:Lt + #:Le)) + +(in-package #:quil/ast/classical) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + (define-type (Arg :num) + (Ref String Ufix) + (Const :num)) + + (define-type (Operation :arg) + ;; Unary + (Not :arg) + (Neg :arg) + ;; Binary + (Move :arg :arg) + (Exchange :arg :arg) + (Convert :arg :arg) + (And :arg :arg) + (IOr :arg :arg) + (XOr :arg :arg) + (Add :arg :arg) + (Sub :arg :arg) + (Mul :arg :arg) + (Div :arg :arg) + ;; Ternary + (Load :arg :arg :arg) + (Store :arg :arg :arg) + (Eq :arg :arg :arg) + (Gt :arg :arg :arg) + (Ge :arg :arg :arg) + (Lt :arg :arg :arg) + (Le :arg :arg :arg))) diff --git a/src/coalton/ast/expression.lisp b/src/coalton/ast/expression.lisp new file mode 100644 index 00000000..1870611b --- /dev/null +++ b/src/coalton/ast/expression.lisp @@ -0,0 +1,35 @@ +(defpackage #:quil/ast/expression + (:use #:coalton) + (:export + #:Expr + #:Add + #:Sub + #:Mul + #:Div + #:Pow + #:Neg + #:Const + #:Call + #:Var + #:Ref)) + +(in-package #:quil/ast/expression) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (define-type (Expr :num) + "Arithmetic expressions appearing in gate application parameter + positions and in gate definitions. In the latter case, Memory + references may not appear." + (Add (Expr :num) (Expr :num)) + (Sub (Expr :num) (Expr :num)) + (Mul (Expr :num) (Expr :num)) + (Div (Expr :num) (Expr :num)) + (Pow (Expr :num) (Expr :num)) + (Neg (Expr :num)) + (Const :num) + (Call String (Expr :num)) + (Var String) + (Ref String Ufix))) diff --git a/src/coalton/ast/gate.lisp b/src/coalton/ast/gate.lisp new file mode 100644 index 00000000..b84b61b1 --- /dev/null +++ b/src/coalton/ast/gate.lisp @@ -0,0 +1,84 @@ +(defpackage #:quil/ast/gate + (:use #:coalton) + (:local-nicknames + (#:expr #:quil/ast/expression)) + (:export + #:Gate + #:I + #:X + #:Y + #:Z + #:H + #:S + #:T + #:RX + #:RY + #:RZ + #:Phase + #:CNOT + #:CZ + #:SWAP + #:ISWAP + #:SQISWAP + #:CSWAP + #:CCNOT + #:PSWAP + #:PISWAP + #:XY + #:CAN + #:BLOCH + #:DAGGER + #:CONTROLLED + #:FORKED)) + +(in-package #:quil/ast/gate) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (define-type (Gate :num :arg) + ;; User-defeind Gate + (Gate String ; Name + (List (expr:Expr :num)) ; Params + (List :arg)) ; Args + ;; Built-in Gates + ;; -- one qubit gates + (I :arg) + (X :arg) + (Y :arg) + (Z :arg) + (H :arg) + (S :arg) + (T :arg) + + ;; -- one parameter one qubit gates + (RX (expr:Expr :num) :arg) + (RY (expr:Expr :num) :arg) + (RZ (expr:Expr :num) :arg) + (Phase (expr:Expr :num) :arg) + + ;; -- two qubit gates + (CNOT :arg :arg) + (CZ :arg :arg) + (SWAP :arg :arg) + (ISWAP :arg :arg) + (SQISWAP :arg :arg) + + ;; -- three qubit gates + (CSWAP :arg :arg :arg) + (CCNOT :arg :arg :arg) + + ;; -- parameterized two qubit gates + (PSWAP (expr:Expr :num) :arg :arg) + (PISWAP (expr:Expr :num) :arg :arg) + (XY (expr:Expr :num) :arg :arg) + + ;; -- multi-parameter gates + (CAN (expr:Expr :num) (expr:Expr :num) (expr:Expr :num) :arg :arg) + (BLOCH (expr:Expr :num) (expr:Expr :num) (expr:Expr :num) :arg) + + ;; --operators + (DAGGER (Gate :num :arg)) + (CONTROLLED :arg (Gate :num :arg)) + (FORKED :arg (List (expr:Expr :num)) (Gate :num :arg)))) diff --git a/src/coalton/ast/macro.lisp b/src/coalton/ast/macro.lisp new file mode 100644 index 00000000..e944dff2 --- /dev/null +++ b/src/coalton/ast/macro.lisp @@ -0,0 +1,67 @@ +(defpackage #:quil/ast/macro + (:use #:coalton) + (:documentation + "A subset of instructions which are permitted to appear inside circuit + definitions.") + (:local-nicknames + (#:classical #:quil/ast/classical) + (#:gate #:quil/ast/gate) + (#:mem #:quil/ast/memory) + (#:expr #:quil/ast/expression)) + (:export + #:MaybeFormal + #:Actual + #:Formal + + #:Instruction + #:ApplyGate + #:ApplyOp + #:ApplyCirc + #:Pragma + #:Label + #:Jump + #:JumpWhen + #:JumpUnless + #:Noop + #:Halt + #:Wait + #:ResetAll + #:Reset + #:Measure + #:MeasureDiscard)) + +(in-package #:quil/ast/macro) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (define-type (MaybeFormal :t) + (Actual :t) + (Formal String)) + + (define-type (Instruction :num) + (ApplyGate (gate:Gate :num (MaybeFormal Ufix))) + (ApplyOp (classical:Operation (MaybeFormal (classical:Arg :num)))) + (ApplyCirc String ; name + (List (expr:Expr :num)) ; params + (List (MaybeFormal Ufix)) ; qubit arguments + (List (Maybeformal mem:Ref))) ; memory refernce arguments + + (Pragma String) + (Label String) + (Jump String) + (JumpWhen String (MaybeFormal mem:Ref)) + (JumpUnless String (MaybeFormal mem:Ref)) + + Noop + Halt + Wait + + ResetAll + (Reset (MaybeFormal Ufix )) + + (Measure (MaybeFormal Ufix) (MaybeFormal mem:Ref)) + (MeasureDiscard (MaybeFormal Ufix)))) + + diff --git a/src/coalton/ast/memory.lisp b/src/coalton/ast/memory.lisp new file mode 100644 index 00000000..cf514851 --- /dev/null +++ b/src/coalton/ast/memory.lisp @@ -0,0 +1,63 @@ +(defpackage #:quil/ast/memory + (:use #:coalton) + (:export + #:QuilType + #:QuilBit + #:QuilOctet + #:QuilInteger + #:QuilReal + #:Ref + #:Offset + #:offset-type + #:offset-amount + #:Descriptor + #:ref-to + #:ref-to-at + #:single + )) + +(in-package #:quil/ast/memory) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (repr :enum) + (define-type QuilType + "A valid data type for Quil memory." + QuilBit QuilOctet QuilInteger QuilReal) + + (define-type Ref + "A Memory Reference" + (Ref String ; name + Ufix)) ; position + + (define-type Offset + "Used in declaring offsets into shared memory declarations" + (Offset QuilType Ufix)) + + (define (offset-type (Offset type _)) type) + (define (offset-amount (Offset _ amount)) amount) + + (define-type Descriptor + (Descriptor + String + QuilType + Ufix + Boolean + (List Offset))) + + ;;; conveniences + + (define (ref-to (Descriptor name _ _ _ _)) + (Ref name 0)) + + (define (ref-to-at (Descriptor name _ _ _ _) i) + (Ref name i)) + + (define (single name type) + (Descriptor name type 1 False Nil)) + + + +) diff --git a/src/coalton/ast/native.lisp b/src/coalton/ast/native.lisp new file mode 100644 index 00000000..493d9e6d --- /dev/null +++ b/src/coalton/ast/native.lisp @@ -0,0 +1,753 @@ +(defpackage #:quil/ast/native + (:use #:coalton) + (:documentation "Native Cl-QUIL and CL-QUIL.FRONTEND Types") + (:import-from #:coalton-library/classes #:map) + (:local-nicknames + (#:quil #:cl-quil.frontend) + (#:mem #:quil/ast/memory) + (#:expr #:quil/ast/expression) + (#:ast #:quil/ast/unresolved) + (#:macro #:quil/ast/macro) + (#:gate #:quil/ast/gate) + (#:classical #:quil/ast/classical))) + +(in-package #:quil/ast/native) + +(named-readtables:in-readtable coalton:coalton) + +;;; HELPERS TO COPE WITH RESOLVING ARITHMETIC EXPRESSIONS TO THEIR +;;; "RAW" CL-QUIL REPRESENTATIONS + +(cl:defun get-expr-params (expr) + "Helper function. Returns a list suitable for filling the PARAMETERS +slot of a DELAYED-EXPRESSION instance." + (cl:etypecase expr + (cl:null cl:nil) + (quil:param (cl:list expr)) + (quil:constant cl:nil) + (quil:delayed-expression + (quil:delayed-expression-params expr)))) + +(cl:defun get-expr-lambda-params (expr) + "Helper function. Returns a list of symbols suitable for filling the +LAMBDA-PARAMETERS slot of a DELAYED-EXPRESSION instance" + (cl:etypecase expr + (cl:null cl:nil) + (quil:param (cl:list (cl:make-symbol (quil:param-name expr)))) + (quil:constant cl:nil) + (quil:delayed-expression + (quil:delayed-expression-lambda-params expr)))) + +(cl:defun get-expr-exprs (expr) + "Helper function, returns a value that can appear as a +sub-expression (a SEXP) in a DELAYED-EXPRESSIONS instance's EXPRESSION +slot." + (cl:etypecase expr + (cl:null cl:nil) + (quil:param (cl:make-symbol (quil:param-name expr))) + (quil:constant (quil:constant-value expr)) + (quil:delayed-expression + (quil:delayed-expression-expression expr)))) + +(cl:defmacro combine-params (str arg1 cl:&optional arg2) + "Generates a form to produce a DELAYED-EXPRESSION out of the values of +forms ARG1 and ARG2, which may be anything that can appear in a +parameter postion of a gate application." + (cl:let* ((var1 (cl:gensym "VAR")) + (var2 (cl:gensym "VAR")) + (vars (cl:list var1 var2)) + (new-params (cl:gensym "PARAMS")) + (new-lambda-params (cl:gensym "LAMBDAPARAMS")) + (new-expression (cl:gensym "EXPR")) + (op (cl:gensym "OP"))) + `(let ((,var1 (expr-to-raw ,arg1)) + (,var2 ,(cl:if arg2 + `(expr-to-raw ,arg2) + `(lisp Param () cl:nil)))) + (lisp Param ,(cl:if (cl:stringp str) vars (cl:cons str vars)) + (cl:let* ((,op (cl:intern (cl:string-upcase ,str) :common-lisp)) + (,new-params + (cl:union (get-expr-params ,var1) + (get-expr-params ,var2) + :test 'cl:equalp)) + (,new-lambda-params + (cl:union (get-expr-lambda-params ,var1) + (get-expr-lambda-params ,var2) + :test 'cl:string=)) + (,new-expression + (cl:list* ,op + (get-expr-exprs ,var1) + (cl:if ,var2 + (cl:list + (get-expr-exprs ,var2)) + cl:nil)))) + (quil:make-delayed-expression + ,new-params ,new-lambda-params ,new-expression)))))) + + +;; ;; HELPER MACROS TO INSTANTIATE CLASSICAL MEMORY OPERATION INSTRUCTIONS + +(cl:defmacro unary-classical-op (mapper name ref) + (cl:let ((rawvar (cl:gensym))) + `(let ((,rawvar (,mapper ,ref))) + (lisp Instruction (,rawvar) + (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) + :target ,rawvar))))) + +(cl:defmacro binary-classical-op (mapper name left right) + (cl:let ((lvar (cl:gensym)) + (rvar (cl:gensym))) + `(let ((,lvar (,mapper ,left)) + (,rvar (,mapper ,right))) + (lisp Instruction (,lvar ,rvar) + (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) + :left ,lvar :right ,rvar))))) + +(cl:defmacro ternary-classical-op (mapper name target left right) + (cl:let ((tvar (cl:gensym)) + (lvar (cl:gensym)) + (rvar (cl:gensym))) + `(let ((,tvar (,mapper ,target)) + (,lvar (,mapper ,left)) + (,rvar (,mapper ,right))) + (lisp Instruction (,tvar ,lvar ,rvar) + (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) + :left ,lvar :right ,rvar :target ,tvar))))) + +(coalton-toplevel + + (repr :native cl-quil:quil-type) + (define-type QuilType) + + (declare raw-quil-type (mem:QuilType -> QuilType)) + (define (raw-quil-type qt) + (match qt + ((mem:QuilBit) (lisp QuilType () quil:quil-bit)) + ((mem:QuilOctet) (lisp QuilType () quil:quil-octet)) + ((mem:QuilInteger) (lisp QuilType () quil:quil-integer)) + ((mem:QuilReal) (lisp QuilType () quil:quil-real)))) + + (repr :native cl-quil:parsed-program) + (define-type Program) + + (repr :native (cl:or cl-quil:qubit cl-quil:formal)) + (define-type QubitArg) + + (repr :native (cl:or cl-quil:formal cl-quil:memory-ref)) + (define-type RefArg) + + (repr :native cl-quil:memory-ref) + (define-type MRef) + + (declare ref-to-raw (mem:Ref -> Mref)) + (define (ref-to-raw (mem:Ref name loc)) + (lisp Mref (name loc) + (quil:mref name loc))) + + (repr :native (cl:or cl-quil:param + cl-quil.frontend:delayed-expression + cl-quil:constant cl:null)) + (define-type Param) + + (repr :native (cl:or cl-quil:instruction + cl-quil:memory-descriptor + cl-quil:jump-target + cl-quil:gate-definition + cl-quil:circuit-definition)) + (define-type Instruction) + + (declare expr-to-raw (expr:Expr :num -> Param)) + (define (expr-to-raw e) + (match e + ((expr:Add e1 e2) (combine-params "+" e1 e2)) + + ((expr:Sub e1 e2) (combine-params "-" e1 e2)) + + ((expr:Mul e1 e2) (combine-params "*" e1 e2)) + + ((expr:Div e1 e2) (combine-params "/" e1 e2)) + + ((expr:Pow e1 e2) (combine-params "EXPT" e1 e2)) + + ((expr:Neg e1) (combine-params "-" e1)) + + ((expr:Const e) + (lisp Param (e) + (quil:constant e))) + + ((expr:Ref name loc) + (let ((rr (lisp Mref (name loc) (quil:mref name loc)))) + (lisp Param (rr) + (quil:make-delayed-expression cl:nil cl:nil rr)))) + + ((expr:Var name) + (lisp Param (name) + (quil:param name))) + + ((expr:Call name e) + (combine-params name e)))) + + (define (ufix-to-qubit u) (lisp QubitArg (u) (quil:qubit u))) + + (declare raw-unresolved-application + (String -> (List (expr:Expr :num)) -> (List Ufix) -> Instruction)) + (define (raw-unresolved-application name params args) + (let ((params* (map expr-to-raw params)) + (args* (map ufix-to-qubit args))) + (lisp Instruction (name params* args*) + (cl:make-instance 'quil:unresolved-application + :operator (quil:named-operator name) + :parameters params* + :arguments args*)))) + + (repr :native (cl:or cl-quil:memory-ref cl-quil:constant cl-quil:formal)) + (define-type ClassicalArg) + + (declare raw-classical-arg (classical:Arg :num -> ClassicalArg)) + (define (raw-classical-arg arg) + (match arg + ((classical:Ref name loc) + (lisp ClassicalArg (name loc) (quil:mref name loc))) + ((classical:Const n) + (lisp ClassicalArg (n) (quil:constant n))))) + + (declare raw-classical-op (classical:Operation (classical:Arg :num) -> Instruction)) + (define (raw-classical-op op) + (match op + ((classical:Neg r) + (unary-classical-op raw-classical-arg "CLASSICAL-NEGATE" r)) + ((classical:Not r) + (unary-classical-op raw-classical-arg "CLASSICAL-NOT" r)) + + ((classical:Move a b) + (binary-classical-op raw-classical-arg "CLASSICAL-MOVE" a b)) + ((classical:Exchange a b) + (binary-classical-op raw-classical-arg "CLASSICAL-EXCHANGE" a b)) + ((classical:Convert a b) + (binary-classical-op raw-classical-arg "CLASSICAL-CONVERT" a b)) + ((classical:And a b) + (binary-classical-op raw-classical-arg "CLASSICAL-AND" a b)) + ((classical:IOr a b) + (binary-classical-op raw-classical-arg "CLASSICAL-INCLUSIVE-OR" a b)) + ((classical:XOr a b) + (binary-classical-op raw-classical-arg "CLASSICAL-EXCLUSIVE-OR" a b)) + ((classical:Add a b) + (binary-classical-op raw-classical-arg "CLASSICAL-ADDITION" a b)) + ((classical:Sub a b) + (binary-classical-op raw-classical-arg "CLASSICAL-SUBTRACTION" a b)) + ((classical:Mul a b) + (binary-classical-op raw-classical-arg "CLASSICAL-MULTIPLICATION" a b)) + ((classical:Div a b) + (binary-classical-op raw-classical-arg "CLASSICAL-DIVISION" a b)) + + ((classical:Load a b c) + (ternary-classical-op raw-classical-arg "CLASSICAL-LOAD" a b c)) + ((classical:Store a b c) + (ternary-classical-op raw-classical-arg "CLASSICAL-STORE" a b c)) + ((classical:Eq a b c) + (ternary-classical-op raw-classical-arg "CLASSICAL-EQUALITY" a b c)) + ((classical:Gt a b c) + (ternary-classical-op raw-classical-arg "CLASSICAL-GREATER-THAN" a b c)) + ((classical:Ge a b c) + (ternary-classical-op raw-classical-arg "CLASSICAL-GREATER-EQUAL" a b c)) + ((classical:Lt a b c) + (ternary-classical-op raw-classical-arg "CLASSICAL-LESS-THAN" a b c)) + ((classical:Le a b c) + (ternary-classical-op raw-classical-arg "CLASSICAL-LESS-EQUAL" a b c)))) + + (define (raw-macro-classical-arg arg) + (match arg + ((macro:Formal s) + (lisp :a (s) (quil:formal s))) + ((macro:Actual a) + (raw-classical-arg a)))) + + (declare raw-macro-classical-op (classical:Operation (macro:MaybeFormal (classical:Arg :num)) -> Instruction)) + (define (raw-macro-classical-op op) + (match op + ((classical:Neg r) + (unary-classical-op raw-macro-classical-arg "CLASSICAL-NEGATE" r)) + ((classical:Not r) + (unary-classical-op raw-macro-classical-arg "CLASSICAL-NOT" r)) + + ((classical:Move a b) + (binary-classical-op raw-macro-classical-arg "CLASSICAL-MOVE" a b)) + ((classical:Exchange a b) + (binary-classical-op raw-macro-classical-arg "CLASSICAL-EXCHANGE" a b)) + ((classical:Convert a b) + (binary-classical-op raw-macro-classical-arg "CLASSICAL-CONVERT" a b)) + ((classical:And a b) + (binary-classical-op raw-macro-classical-arg "CLASSICAL-AND" a b)) + ((classical:IOr a b) + (binary-classical-op raw-macro-classical-arg "CLASSICAL-INCLUSIVE-OR" a b)) + ((classical:XOr a b) + (binary-classical-op raw-macro-classical-arg "CLASSICAL-EXCLUSIVE-OR" a b)) + ((classical:Add a b) + (binary-classical-op raw-macro-classical-arg "CLASSICAL-ADDITION" a b)) + ((classical:Sub a b) + (binary-classical-op raw-macro-classical-arg "CLASSICAL-SUBTRACTION" a b)) + ((classical:Mul a b) + (binary-classical-op raw-macro-classical-arg "CLASSICAL-MULTIPLICATION" a b)) + ((classical:Div a b) + (binary-classical-op raw-macro-classical-arg "CLASSICAL-DIVISION" a b)) + + ((classical:Load a b c) + (ternary-classical-op raw-macro-classical-arg "CLASSICAL-LOAD" a b c)) + ((classical:Store a b c) + (ternary-classical-op raw-macro-classical-arg "CLASSICAL-STORE" a b c)) + ((classical:Eq a b c) + (ternary-classical-op raw-macro-classical-arg "CLASSICAL-EQUALITY" a b c)) + ((classical:Gt a b c) + (ternary-classical-op raw-macro-classical-arg "CLASSICAL-GREATER-THAN" a b c)) + ((classical:Ge a b c) + (ternary-classical-op raw-macro-classical-arg "CLASSICAL-GREATER-EQUAL" a b c)) + ((classical:Lt a b c) + (ternary-classical-op raw-macro-classical-arg "CLASSICAL-LESS-THAN" a b c)) + ((classical:Le a b c) + (ternary-classical-op raw-macro-classical-arg "CLASSICAL-LESS-EQUAL" a b c)))) + + (declare raw-gate-def (String -> (ast:GateDef :num) -> Instruction)) + (define (raw-gate-def name gdef) + (match gdef + ((ast:PermuationGateDef vals) + (lisp Instruction (name vals) + (cl:make-instance 'quil:permutation-gate-definition + :name name :permutation vals :context cl:nil))) + + ((ast:ParameterizedGateDef params exprs) + (let ((exprs* (map expr-to-raw exprs))) + (lisp Instruction (name params exprs*) + (cl:make-instance 'quil:parameterized-gate-definition + :name name + :entries (cl:mapcar 'get-expr-exprs exprs*) + :parameters (cl:mapcar 'cl:make-symbol params))))) + + ((ast:StaticGateDef entries) + (lisp Instruction (name entries) + (cl:make-instance 'quil:static-gate-definition + :name name + :entries entries))) + + ((ast:PauliSumGateDef terms params args) + (lisp Instruction (name terms params args) + (cl:make-instance 'quil:exp-pauli-sum-gate-definition + :name name + :arguments (cl:mapcar #'quil:formal args) + :parameters (cl:mapcar 'cl:make-symbol params) + :terms (cl:loop :for term :in terms + :collect (quil:make-pauli-term + :pauli-word (ast:pauli-term-word term) + :prefactor (ast:pauli-term-prefactor term) + :arguments (cl:mapcar #'quil:formal (ast:pauli-term-arguments term))))))))) + + + (declare raw-mem-descriptor (mem:Descriptor -> Instruction)) + (define (raw-mem-descriptor (mem:Descriptor name type length sharing offsets)) + (lisp Instruction (name type length sharing offsets) + (quil:make-memory-descriptor + :name name + :type (raw-quil-type type) + :length length + :sharing-parent sharing + :sharing-offset-alist + (cl:loop :for offset :in offsets + :collect (cl:cons + (raw-quil-type (mem:offset-type offset)) + (mem:offset-amount offset)))))) + + (repr :native (cl:or quil:memory-ref quil:formal)) + (define-type MemRefArg) + + (define (raw-maybeformal-mem-ref m) + (match m + ((macro:Formal s) (lisp MemRefArg (s) (quil:formal s))) + ((macro:Actual (mem:Ref name loc)) + (lisp MemRefArg (name loc) (quil:mref name loc))))) + + (repr :native (cl:or quil:qubit quil:formal)) + (define-type FormalQbArg) + + (define (raw-maybeformal-qubit q) + (match q + ((macro:Formal s) (lisp FormalQbArg (s) (quil:formal s))) + ((macro:Actual n) (lisp FormalQbArg (n) (quil:qubit n))))) + + + (declare macro-instr-to-raw (macro:Instruction :num -> Instruction)) + (define (macro-instr-to-raw instr) + (match instr + ((macro:ApplyGate g) + (macro-gate-to-raw g)) + + ((macro:ApplyOp op) + (raw-macro-classical-op op)) + + ((macro:ApplyCirc name params qargs refargs) + (let ((params* (map expr-to-raw params)) + (qargs* (map raw-maybeformal-qubit qargs)) + (refargs* (map raw-maybeformal-mem-ref refargs))) + (lisp Instruction (name params* qargs* refargs*) + (cl:make-instance 'quil:unresolved-application + :operator (quil:named-operator name) + :parameters params* + :arguments (cl:nconc qargs* refargs*))))) + + ((macro:Pragma pstring) + (lisp Instruction (pstring) + (quil::parse-pragma + (quil::tokenize + (cl:with-output-to-string (out) + (cl:write-string "PRAGMA ") + (cl:write-string pstring)))))) + + ((macro:Label s) + (lisp Instruction (s) + (cl:make-instance 'quil:jump-target + :label (quil:label s)))) + + ((macro:Jump s) + (lisp Instruction (s) + (cl:make-instance 'quil:unconditional-jump + :label (quil:label s)))) + + ((macro:Noop) + (lisp Instruction () + (cl:make-instance 'quil:no-operation))) + + ((macro:Halt) + (lisp Instruction () + (cl:make-instance 'quil:halt))) + + + ((macro:Wait) + (lisp Instruction () + (cl:make-instance 'quil:wait))) + + ((macro:ResetAll) + (lisp Instruction () + (cl:make-instance 'quil:reset))) + + ((macro:JumpWhen s rf) + (let ((rf* (raw-maybeformal-mem-ref rf))) + (lisp Instruction (s rf*) + (cl:make-instance 'quil:jump-when + :label (quil:label s) + :address rf*)))) + + ((macro:JumpUnless s rf) + (let ((rf* (raw-maybeformal-mem-ref rf))) + (lisp Instruction (s rf*) + (cl:make-instance 'quil:jump-unless + :label (quil:label s) + :address rf*)))) + + ((macro:reset qb) + (let ((qb* (raw-maybeformal-qubit qb))) + (lisp Instruction (qb*) + (cl:make-instance 'quil:reset-qubit :target qb*)))) + + ((macro:Measure qb rf) + (let ((qb* (raw-maybeformal-qubit qb)) + (rf* (raw-maybeformal-mem-ref rf))) + (lisp Instruction (qb* rf*) + (cl:make-instance 'quil:measure :address rf* :qubit qb*)))) + + ((macro:MeasureDiscard qb) + (let ((qb* (raw-maybeformal-qubit qb))) + (lisp Instruction (qb*) + (cl:make-instance 'quil:measure-discard :qubit qb*)))))) + + + (declare instr-to-raw (ast:Instruction :num -> Instruction)) + (define (instr-to-raw instr) + (match instr + ((ast:ApplyGate g) (gate-to-raw g)) + + ((ast:Include name) + (lisp Instruction (name) + (cl:make-instance 'quil:include :pathname name))) + + ((ast:Pragma pstring) + (lisp Instruction (pstring) + (quil::parse-pragma + (quil::tokenize + (cl:with-output-to-string (out) + (cl:write-string "PRAGMA ") + (cl:write-string pstring)))))) + + ((ast:DeclareMem descriptor) + (raw-mem-descriptor descriptor)) + + ((ast:GateDefinition name gdef) + (raw-gate-def name gdef)) + + ((ast:CircuitDefinition name params qargs rargs body) + (let ((instrs (map macro-instr-to-raw body))) + (lisp Instruction (name params qargs rargs instrs) + (cl:make-instance 'quil:circuit-definition + :name name + :parameters (cl:mapcar 'quil:param params) + :arguments (cl:mapcar 'quil:formal (cl:nconc qargs rargs)) + :body instrs)))) + + ((ast:ApplyOp op) + (raw-classical-op op)) + + ((ast:ApplyCirc name params qargs refargs) + (let ((params* (map expr-to-raw params)) + (qargs* (map ufix-to-qubit qargs)) + (refargs* (map ref-to-raw refargs))) + (lisp Instruction (name params* qargs* refargs*) + (cl:make-instance 'quil:unresolved-application + :operator (quil:named-operator name) + :parameters params* + :arguments (cl:nconc qargs* refargs*))))) + + ((ast:Label l) + (lisp Instruction (l) + (cl:make-instance 'quil:jump-target + :label (quil:label l)))) + + ((ast:Jump l) + (lisp Instruction (l) + (cl:make-instance 'quil:unconditional-jump + :label (quil:label l)))) + + ((ast:JumpWhen l a) + (lisp Instruction (l a) + (cl:make-instance 'quil:jump-when + :label (quil:label l) + :address (ref-to-raw a)))) + + ((ast:JumpUnless l a) + (lisp Instruction (l a) + (cl:make-instance 'quil:jump-unless + :label (quil:label l) + :address (ref-to-raw a)))) + + ((ast:Noop) + (lisp Instruction () + (cl:make-instance 'quil:no-operation))) + + ((ast:Halt) + (lisp Instruction () + (cl:make-instance 'quil:halt))) + + + ((ast:Wait) + (lisp Instruction () + (cl:make-instance 'quil:wait))) + + ((ast:ResetAll) + (lisp Instruction () + (cl:make-instance 'quil:reset))) + + ((ast:Reset qb) + (let ((qb* (ufix-to-qubit qb))) + (lisp Instruction (qb*) + (cl:make-instance 'quil:reset-qubit :target qb*)))) + + ((ast:Measure qb loc) + (let ((qb* (ufix-to-qubit qb)) + (loc* (ref-to-raw loc))) + (lisp Instruction (qb* loc*) + (cl:make-instance 'quil:measure :address loc* :qubit qb*)))) + + ((ast:MeasureDiscard qb) + (let ((qb* (ufix-to-qubit qb))) + (lisp Instruction (qb*) + (cl:make-instance 'quil:measure-discard :qubit qb*)))))) + + (declare gate-to-raw ((gate:Gate :num Ufix) -> Instruction)) + (define (gate-to-raw g) + (match g + ((gate:Gate name params args) + (raw-unresolved-application name params args)) + ((gate:I a) + (raw-unresolved-application "I" nil (make-list a))) + ((gate:X a) + (raw-unresolved-application "X" nil (make-list a))) + ((gate:Y a) + (raw-unresolved-application "Y" nil (make-list a))) + ((gate:Z a) + (raw-unresolved-application "Z" nil (make-list a))) + ((gate:H a) + (raw-unresolved-application "H" nil (make-list a))) + ((gate:S a) + (raw-unresolved-application "S" nil (make-list a))) + ((gate:T a) + (raw-unresolved-application "T" nil (make-list a))) + ((gate:RX e a) + (raw-unresolved-application "RX" (make-list e) (make-list a))) + ((gate:RY e a) + (raw-unresolved-application "RY" (make-list e) (make-list a))) + ((gate:RZ e a) + (raw-unresolved-application "RZ" (make-list e) (make-list a))) + ((gate:PHASE e a) + (raw-unresolved-application "PHASE" (make-list e) (make-list a))) + ((gate:CNOT a b) + (raw-unresolved-application "CNOT" nil (make-list a b))) + ((gate:CZ a b) + (raw-unresolved-application "CZ" nil (make-list a b))) + ((gate:SWAP a b) + (raw-unresolved-application "SWAP" nil (make-list a b))) + ((gate:ISWAP a b) + (raw-unresolved-application "ISWAP" nil (make-list a b))) + ((gate:SQISWAP a b) + (raw-unresolved-application "SQISWAP" nil (make-list a b))) + ((gate:CSWAP a b c) + (raw-unresolved-application "CSWAP" nil (make-list a b c))) + ((gate:CCNOT a b c) + (raw-unresolved-application "CCNOT" nil (make-list a b c))) + ((gate:PSWAP e a b) + (raw-unresolved-application "PSWAP" (make-list e) (make-list a b))) + ((gate:PISWAP e a b) + (raw-unresolved-application "PISWAP" (make-list e) (make-list a b))) + ((gate:XY e a b) + (raw-unresolved-application "XY" (make-list e) (make-list a b))) + ((gate:CAN alpha beta gamma a b) + (raw-unresolved-application "CAN" + (make-list alpha beta gamma) + (make-list a b))) + ((gate:BLOCH a b c q) + (raw-unresolved-application "BLOCH" (make-list a b c) (make-list q))) + ((gate:DAGGER g) + (let ((gapp (gate-to-raw g))) + (lisp Instruction (gapp) + (cl:setf (quil:application-operator gapp) + (quil:dagger-operator (quil:application-operator gapp))) + gapp))) + ((gate:CONTROLLED q g) + (let ((gapp (gate-to-raw g)) + (rawq (ufix-to-qubit q))) + (lisp Instruction (gapp rawq) + (cl:setf (quil:application-operator gapp) + (quil:controlled-operator (quil:application-operator gapp))) + (cl:setf (quil:application-arguments gapp) + (cons rawq + (quil:application-arguments gapp))) + gapp))) + + ((gate:FORKED ctl ps g) + (let ((gapp (gate-to-raw g)) + (rawctl (ufix-to-qubit ctl)) + (rawps (map expr-to-raw ps))) + (lisp Instruction (gapp rawctl rawps) + (cl:setf (quil:application-operator gapp) + (quil:forked-operator (quil:application-operator gapp))) + (cl:setf (quil:application-parameters gapp) + (cl:nconc rawps (quil:application-parameters gapp))) + (cl:setf (quil:application-arguments gapp) + (cons rawctl (quil:application-arguments gapp))) + gapp))))) + + (declare raw-macro-unresolved-application + (String -> + (List (expr:Expr :num)) -> + (List (macro:MaybeFormal Ufix)) -> + Instruction)) + (define (raw-macro-unresolved-application name params args) + (let ((params* (map expr-to-raw params)) + (args* (map raw-maybeformal-qubit args))) + (lisp Instruction (name params* args*) + (cl:make-instance 'quil:unresolved-application + :operator (quil:named-operator name) + :parameters params* + :arguments args*)))) + + (define (macro-gate-to-raw g) + (match g + ((gate:Gate name params args) + (raw-macro-unresolved-application name params args)) + ((gate:I a) + (raw-macro-unresolved-application "I" nil (make-list a))) + ((gate:X a) + (raw-macro-unresolved-application "X" nil (make-list a))) + ((gate:Y a) + (raw-macro-unresolved-application "Y" nil (make-list a))) + ((gate:Z a) + (raw-macro-unresolved-application "Z" nil (make-list a))) + ((gate:H a) + (raw-macro-unresolved-application "H" nil (make-list a))) + ((gate:S a) + (raw-macro-unresolved-application "S" nil (make-list a))) + ((gate:T a) + (raw-macro-unresolved-application "T" nil (make-list a))) + ((gate:RX e a) + (raw-macro-unresolved-application "RX" (make-list e) (make-list a))) + ((gate:RY e a) + (raw-macro-unresolved-application "RY" (make-list e) (make-list a))) + ((gate:RZ e a) + (raw-macro-unresolved-application "RZ" (make-list e) (make-list a))) + ((gate:PHASE e a) + (raw-macro-unresolved-application "PHASE" (make-list e) (make-list a))) + ((gate:CNOT a b) + (raw-macro-unresolved-application "CNOT" nil (make-list a b))) + ((gate:CZ a b) + (raw-macro-unresolved-application "CZ" nil (make-list a b))) + ((gate:SWAP a b) + (raw-macro-unresolved-application "SWAP" nil (make-list a b))) + ((gate:ISWAP a b) + (raw-macro-unresolved-application "ISWAP" nil (make-list a b))) + ((gate:SQISWAP a b) + (raw-macro-unresolved-application "SQISWAP" nil (make-list a b))) + ((gate:CSWAP a b c) + (raw-macro-unresolved-application "CSWAP" nil (make-list a b c))) + ((gate:CCNOT a b c) + (raw-macro-unresolved-application "CCNOT" nil (make-list a b c))) + ((gate:PSWAP e a b) + (raw-macro-unresolved-application "PSWAP" (make-list e) (make-list a b))) + ((gate:PISWAP e a b) + (raw-macro-unresolved-application "PISWAP" (make-list e) (make-list a b))) + ((gate:XY e a b) + (raw-macro-unresolved-application "XY" (make-list e) (make-list a b))) + ((gate:CAN alpha beta gamma a b) + (raw-macro-unresolved-application "CAN" + (make-list alpha beta gamma) + (make-list a b))) + ((gate:BLOCH a b c q) + (raw-macro-unresolved-application "BLOCH" (make-list a b c) (make-list q))) + ((gate:DAGGER g) + (let ((gapp (macro-gate-to-raw g))) + (lisp Instruction (gapp) + (cl:setf (quil:application-operator gapp) + (quil:dagger-operator (quil:application-operator gapp))) + gapp))) + ((gate:CONTROLLED q g) + (let ((gapp (macro-gate-to-raw g)) + (rawq (raw-maybeformal-qubit q))) + (lisp Instruction (gapp rawq) + (cl:setf (quil:application-operator gapp) + (quil:controlled-operator (quil:application-operator gapp))) + (cl:setf (quil:application-arguments gapp) + (cons rawq + (quil:application-arguments gapp))) + gapp))) + + ((gate:FORKED ctl ps g) + (let ((gapp (macro-gate-to-raw g)) + (rawctl (raw-maybeformal-qubit ctl)) + (rawps (map expr-to-raw ps))) + (lisp Instruction (gapp rawctl rawps) + (cl:setf (quil:application-operator gapp) + (quil:forked-operator (quil:application-operator gapp))) + (cl:setf (quil:application-parameters gapp) + (cl:nconc rawps (quil:application-parameters gapp))) + (cl:setf (quil:application-arguments gapp) + (cons rawctl (quil:application-arguments gapp))) + gapp))))) + + + (declare build-resolved-program (List (ast:Instruction :num) -> Program)) + (define (build-resolved-program instrs) + (let ((raw-instrs (map instr-to-raw instrs))) + (lisp Program (raw-instrs) + (cl:let ((pp (quil:resolve-objects + (quil::raw-quil-to-unresolved-program + raw-instrs)))) + (cl:dolist (xform quil::*standard-post-parsing-transforms*) + (cl:setf pp (quil:transform xform pp))) + pp)))) + + ;;eof + ) diff --git a/src/coalton/ast/unresolved.lisp b/src/coalton/ast/unresolved.lisp index 3141df32..93077050 100644 --- a/src/coalton/ast/unresolved.lisp +++ b/src/coalton/ast/unresolved.lisp @@ -1,83 +1,33 @@ (defpackage #:quil/ast/unresolved (:use #:coalton) (:import-from #:coalton) - (:export - #:Ref - #:Add - #:Sub - #:Mul - #:Div - #:Pow - #:Neg - #:Const - #:Call - #:Var - #:RefExpr - #:Expr - - #:MaybeFormal - #:Actual - #:Formal - - #:Gate - #:I #:X #:Y #:Z #:H #:S #:T - #:RX #:RY #:RZ #:Phase - #:CNOT #:CZ #:SWAP #:ISWAP #:SQISWAP - #:CSWAP #:CCNOT - #:PSWAP #:PISWAP #:XY - #:CAN - #:BLOCH - #:DAGGER - #:CONTROLLED - #:FORKED - - #:QuilType - #:QuilBit #:QuilOctet #:QuilInteger #:QuilReal - - #:MemOffset - #:offset-type #:offset-amount + (:local-nicknames + (#:expr #:quil/ast/expression) + (#:macro #:quil/ast/macro) + (#:gate #:quil/ast/gate) + (#:mem #:quil/ast/memory) + (#:classical #:quil/ast/classical)) + (:export #:PauliTerm #:pauli-term-word #:pauli-term-prefactor #:pauli-term-arguments - #:GateDef #:PermuationGateDef #:StaticGateDef #:ParameterizedGateDef #:PauliSumGateDef - - #:ClassicalOperation - #:NotOp - #:NegOp - #:MoveOp - #:ExchangeOp - #:ConvertOp - #:AndOp - #:IOrOp - #:XOrOp - #:AddOp - #:SubOp - #:MulOp - #:DivOp - #:LoadOp - #:StoreOp - #:EqOp - #:GtOp - #:GeOp - #:LtOp - #:LeOp - #:Instruction #:ApplyGate + #:ApplyOp + #:ApplyCirc #:Include #:Pragma - #:Memory + #:DeclareMem #:GateDefinition #:CircuitDefinition #:Label - #:ApplyOp #:Jump #:JumpWhen #:JumpUnless @@ -88,8 +38,6 @@ #:Reset #:Measure #:MeasureDiscard)) - - (in-package #:quil/ast/unresolved) @@ -97,91 +45,6 @@ (coalton-toplevel - (define-type Ref - "A Memory Reference" - (Ref String ; name - Ufix ; position - )) - - (define-type (Expr :num) - "Arithmetic expressions appearing in gate application parameter - positions and in gate definitions. In the latter case, Memory - references may not appear." - (Add (Expr :num) (Expr :num)) - (Sub (Expr :num) (Expr :num)) - (Mul (Expr :num) (Expr :num)) - (Div (Expr :num) (Expr :num)) - (Pow (Expr :num) (Expr :num)) - (Neg (Expr :num)) - (Const :num) - (Call String (Expr :num)) - (Var String) - (RefExpr Ref)) - - (define-type (MaybeFormal :t) - "A wrapper type representing a value which may in some contexts be - represented by a formal name." - (Actual :t) - (Formal String)) - - (define-type (Gate :num) - ;; User-defeind Gate - (Gate String ; Name - (List (Expr :num)) ; Params - (List (MaybeFormal Ufix))) ; Args - ;; Built-in Gates - ;; -- one qubit gates - (I (MaybeFormal Ufix)) - (X (MaybeFormal Ufix)) - (Y (MaybeFormal Ufix)) - (Z (MaybeFormal Ufix)) - (H (MaybeFormal Ufix)) - (S (MaybeFormal Ufix)) - (T (MaybeFormal Ufix)) - - ;; -- one parameter one qubit gates - (RX (Expr :num) (MaybeFormal Ufix)) - (RY (Expr :num) (MaybeFormal Ufix)) - (RZ (Expr :num) (MaybeFormal Ufix)) - (Phase (Expr :num) (MaybeFormal Ufix)) - - ;; -- two qubit gates - (CNOT (MaybeFormal Ufix) (MaybeFormal Ufix)) - (CZ (MaybeFormal Ufix) (MaybeFormal Ufix)) - (SWAP (MaybeFormal Ufix) (MaybeFormal Ufix)) - (ISWAP (MaybeFormal Ufix) (MaybeFormal Ufix)) - (SQISWAP (MaybeFormal Ufix) (MaybeFormal Ufix)) - - ;; -- three qubit gates - (CSWAP (MaybeFormal Ufix) (MaybeFormal Ufix) (MaybeFormal Ufix)) - (CCNOT (MaybeFormal Ufix) (MaybeFormal Ufix) (MaybeFormal Ufix)) - - ;; -- parameterized two qubit gates - (PSWAP (Expr :num) (MaybeFormal Ufix) (MaybeFormal Ufix)) - (PISWAP (Expr :num) (MaybeFormal Ufix) (MaybeFormal Ufix)) - (XY (Expr :num) (MaybeFormal Ufix) (MaybeFormal Ufix)) - - ;; -- multi-parameter gates - (CAN (Expr :num) (Expr :num) (Expr :num) (MaybeFormal Ufix) (MaybeFormal Ufix)) - (BLOCH (Expr :num) (Expr :num) (Expr :num) (MaybeFormal Ufix)) - - ;; --operators - (DAGGER (Gate :num)) - (CONTROLLED (MaybeFormal Ufix) (Gate :num)) - (FORKED (MaybeFormal Ufix) (List (Expr :num)) (Gate :num))) - - (repr :enum) - (define-type QuilType - "A valid data type for Quil memory." - QuilBit QuilOctet QuilInteger QuilReal) - - (define-type MemOffset - "Used in declaring offsets into shared memory declarations" - (MemOffset QuilType Ufix)) - - (define (offset-type (MemOffset type _)) type) - (define (offset-amount (MemOffset _ amount)) amount) - (define-type (PauliTerm :num) (PauliTerm String ; pauli word, string of pauli gate names X,Y,Z,I :num ; prefactor @@ -195,48 +58,27 @@ (PermuationGateDef (List UFix)) (StaticGateDef (List :num)) (ParameterizedGateDef (List String) - (List (Expr :num))) + (List (expr:Expr :num))) (PauliSumGateDef (List (PauliTerm :num)) ; terms (List String) ; params (List String))) ; arguments - (define-type ClassicalOperation - ;; Unary - (NotOp (MaybeFormal Ref)) - (NegOp (MaybeFormal Ref)) - ;; Binary - (MoveOp (MaybeFormal Ref) (MaybeFormal Ref)) - (ExchangeOp (MaybeFormal Ref) (MaybeFormal Ref)) - (ConvertOp (MaybeFormal Ref) (MaybeFormal Ref)) - (AndOp (MaybeFormal Ref) (MaybeFormal Ref)) - (IOrOp (MaybeFormal Ref) (MaybeFormal Ref)) - (XOrOp (MaybeFormal Ref) (MaybeFormal Ref)) - (AddOp (MaybeFormal Ref) (MaybeFormal Ref)) - (SubOp (MaybeFormal Ref) (MaybeFormal Ref)) - (MulOp (MaybeFormal Ref) (MaybeFormal Ref)) - (DivOp (MaybeFormal Ref) (MaybeFormal Ref)) - ;; Ternary - (LoadOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref)) - (StoreOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref)) - (EqOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref)) - (GtOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref)) - (GeOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref)) - (LtOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref)) - (LeOp (MaybeFormal Ref) (MaybeFormal Ref) (MaybeFormal Ref))) - (define-type (Instruction :num) ;; generic gate/circuit application - (ApplyGate (Gate :num)) + (ApplyGate (gate:Gate :num Ufix)) + (ApplyOp (classical:Operation (classical:Arg :num))) + (ApplyCirc String ; name + (List (expr:Expr :num)) ; params + (List Ufix) ; qubit arguments + (List mem:Ref) ; memory refernce argumetns + ) + ;; include a .quil file (Include String) ;; E.g. (Pragma "REWIRING_SEARCH \"A*\"") (Pragma String) ;; Classical Memory Declaration - (Memory String ; name - QuilType ; type - UFix ; length - Boolean ; sharing parent - (List MemOffset)) ; sharing offsets + (DeclareMem mem:Descriptor) (GateDefinition String ; name (GateDef :num)) ; definition @@ -244,26 +86,25 @@ (CircuitDefinition String ; name (List String) ; parameter names - (List String) ; arguments names - (List (Instruction :num))) ; body + (List String) ; qubit arg names + (List String) ; memref arg names + (List (macro:Instruction :num))) ; body (Label String) - (ApplyOp ClassicalOperation) - (Jump String) - (JumpWhen String (MaybeFormal Ref)) - (JumpUnless String (MaybeFormal Ref)) + (JumpWhen String mem:Ref) + (JumpUnless String mem:Ref) Noop Halt Wait ResetAll - (Reset (MaybeFormal Ufix)) + (Reset Ufix) - (Measure (MaybeFormal Ufix) (MaybeFormal Ref)) - (MeasureDiscard (MaybeFormal Ufix))) + (Measure Ufix mem:Ref) + (MeasureDiscard Ufix)) ;; end module ) From 48c50f9911bba87e2d9f661b90858b1fd511a058 Mon Sep 17 00:00:00 2001 From: Colin O'Keefe Date: Wed, 25 Sep 2024 20:08:03 -0700 Subject: [PATCH 5/7] naming decisions; bugfix in native construction of pragmas --- src/coalton/ast/classical.lisp | 9 ++-- src/coalton/ast/native.lisp | 96 +++++++++++++++++----------------- 2 files changed, 54 insertions(+), 51 deletions(-) diff --git a/src/coalton/ast/classical.lisp b/src/coalton/ast/classical.lisp index 2d6f5d60..bbc8b6b4 100644 --- a/src/coalton/ast/classical.lisp +++ b/src/coalton/ast/classical.lisp @@ -1,9 +1,11 @@ (defpackage #:quil/ast/classical (:use #:coalton) (:shadow #:And) + (:local-nicknames + (#:mem #:quil/ast/memory)) (:export #:Arg - #:Ref + #:Mem #:Const #:Operation #:Not @@ -31,10 +33,11 @@ (named-readtables:in-readtable coalton:coalton) (coalton-toplevel + (define-type (Arg :num) - (Ref String Ufix) + (Mem mem:Ref) (Const :num)) - + (define-type (Operation :arg) ;; Unary (Not :arg) diff --git a/src/coalton/ast/native.lisp b/src/coalton/ast/native.lisp index 493d9e6d..658a11e8 100644 --- a/src/coalton/ast/native.lisp +++ b/src/coalton/ast/native.lisp @@ -9,7 +9,7 @@ (#:ast #:quil/ast/unresolved) (#:macro #:quil/ast/macro) (#:gate #:quil/ast/gate) - (#:classical #:quil/ast/classical))) + (#:op #:quil/ast/classical))) (in-package #:quil/ast/native) @@ -203,56 +203,56 @@ parameter postion of a gate application." (repr :native (cl:or cl-quil:memory-ref cl-quil:constant cl-quil:formal)) (define-type ClassicalArg) - (declare raw-classical-arg (classical:Arg :num -> ClassicalArg)) + (declare raw-classical-arg (op:Arg :num -> ClassicalArg)) (define (raw-classical-arg arg) (match arg - ((classical:Ref name loc) + ((op:Mem (mem:Ref name loc)) (lisp ClassicalArg (name loc) (quil:mref name loc))) - ((classical:Const n) + ((op:Const n) (lisp ClassicalArg (n) (quil:constant n))))) - (declare raw-classical-op (classical:Operation (classical:Arg :num) -> Instruction)) + (declare raw-classical-op (op:Operation (op:Arg :num) -> Instruction)) (define (raw-classical-op op) (match op - ((classical:Neg r) + ((op:Neg r) (unary-classical-op raw-classical-arg "CLASSICAL-NEGATE" r)) - ((classical:Not r) + ((op:Not r) (unary-classical-op raw-classical-arg "CLASSICAL-NOT" r)) - ((classical:Move a b) + ((op:Move a b) (binary-classical-op raw-classical-arg "CLASSICAL-MOVE" a b)) - ((classical:Exchange a b) + ((op:Exchange a b) (binary-classical-op raw-classical-arg "CLASSICAL-EXCHANGE" a b)) - ((classical:Convert a b) + ((op:Convert a b) (binary-classical-op raw-classical-arg "CLASSICAL-CONVERT" a b)) - ((classical:And a b) + ((op:And a b) (binary-classical-op raw-classical-arg "CLASSICAL-AND" a b)) - ((classical:IOr a b) + ((op:IOr a b) (binary-classical-op raw-classical-arg "CLASSICAL-INCLUSIVE-OR" a b)) - ((classical:XOr a b) + ((op:XOr a b) (binary-classical-op raw-classical-arg "CLASSICAL-EXCLUSIVE-OR" a b)) - ((classical:Add a b) + ((op:Add a b) (binary-classical-op raw-classical-arg "CLASSICAL-ADDITION" a b)) - ((classical:Sub a b) + ((op:Sub a b) (binary-classical-op raw-classical-arg "CLASSICAL-SUBTRACTION" a b)) - ((classical:Mul a b) + ((op:Mul a b) (binary-classical-op raw-classical-arg "CLASSICAL-MULTIPLICATION" a b)) - ((classical:Div a b) + ((op:Div a b) (binary-classical-op raw-classical-arg "CLASSICAL-DIVISION" a b)) - ((classical:Load a b c) + ((op:Load a b c) (ternary-classical-op raw-classical-arg "CLASSICAL-LOAD" a b c)) - ((classical:Store a b c) + ((op:Store a b c) (ternary-classical-op raw-classical-arg "CLASSICAL-STORE" a b c)) - ((classical:Eq a b c) + ((op:Eq a b c) (ternary-classical-op raw-classical-arg "CLASSICAL-EQUALITY" a b c)) - ((classical:Gt a b c) + ((op:Gt a b c) (ternary-classical-op raw-classical-arg "CLASSICAL-GREATER-THAN" a b c)) - ((classical:Ge a b c) + ((op:Ge a b c) (ternary-classical-op raw-classical-arg "CLASSICAL-GREATER-EQUAL" a b c)) - ((classical:Lt a b c) + ((op:Lt a b c) (ternary-classical-op raw-classical-arg "CLASSICAL-LESS-THAN" a b c)) - ((classical:Le a b c) + ((op:Le a b c) (ternary-classical-op raw-classical-arg "CLASSICAL-LESS-EQUAL" a b c)))) (define (raw-macro-classical-arg arg) @@ -262,48 +262,48 @@ parameter postion of a gate application." ((macro:Actual a) (raw-classical-arg a)))) - (declare raw-macro-classical-op (classical:Operation (macro:MaybeFormal (classical:Arg :num)) -> Instruction)) + (declare raw-macro-classical-op (op:Operation (macro:MaybeFormal (op:Arg :num)) -> Instruction)) (define (raw-macro-classical-op op) (match op - ((classical:Neg r) + ((op:Neg r) (unary-classical-op raw-macro-classical-arg "CLASSICAL-NEGATE" r)) - ((classical:Not r) + ((op:Not r) (unary-classical-op raw-macro-classical-arg "CLASSICAL-NOT" r)) - ((classical:Move a b) + ((op:Move a b) (binary-classical-op raw-macro-classical-arg "CLASSICAL-MOVE" a b)) - ((classical:Exchange a b) + ((op:Exchange a b) (binary-classical-op raw-macro-classical-arg "CLASSICAL-EXCHANGE" a b)) - ((classical:Convert a b) + ((op:Convert a b) (binary-classical-op raw-macro-classical-arg "CLASSICAL-CONVERT" a b)) - ((classical:And a b) + ((op:And a b) (binary-classical-op raw-macro-classical-arg "CLASSICAL-AND" a b)) - ((classical:IOr a b) + ((op:IOr a b) (binary-classical-op raw-macro-classical-arg "CLASSICAL-INCLUSIVE-OR" a b)) - ((classical:XOr a b) + ((op:XOr a b) (binary-classical-op raw-macro-classical-arg "CLASSICAL-EXCLUSIVE-OR" a b)) - ((classical:Add a b) + ((op:Add a b) (binary-classical-op raw-macro-classical-arg "CLASSICAL-ADDITION" a b)) - ((classical:Sub a b) + ((op:Sub a b) (binary-classical-op raw-macro-classical-arg "CLASSICAL-SUBTRACTION" a b)) - ((classical:Mul a b) + ((op:Mul a b) (binary-classical-op raw-macro-classical-arg "CLASSICAL-MULTIPLICATION" a b)) - ((classical:Div a b) + ((op:Div a b) (binary-classical-op raw-macro-classical-arg "CLASSICAL-DIVISION" a b)) - ((classical:Load a b c) + ((op:Load a b c) (ternary-classical-op raw-macro-classical-arg "CLASSICAL-LOAD" a b c)) - ((classical:Store a b c) + ((op:Store a b c) (ternary-classical-op raw-macro-classical-arg "CLASSICAL-STORE" a b c)) - ((classical:Eq a b c) + ((op:Eq a b c) (ternary-classical-op raw-macro-classical-arg "CLASSICAL-EQUALITY" a b c)) - ((classical:Gt a b c) + ((op:Gt a b c) (ternary-classical-op raw-macro-classical-arg "CLASSICAL-GREATER-THAN" a b c)) - ((classical:Ge a b c) + ((op:Ge a b c) (ternary-classical-op raw-macro-classical-arg "CLASSICAL-GREATER-EQUAL" a b c)) - ((classical:Lt a b c) + ((op:Lt a b c) (ternary-classical-op raw-macro-classical-arg "CLASSICAL-LESS-THAN" a b c)) - ((classical:Le a b c) + ((op:Le a b c) (ternary-classical-op raw-macro-classical-arg "CLASSICAL-LESS-EQUAL" a b c)))) (declare raw-gate-def (String -> (ast:GateDef :num) -> Instruction)) @@ -397,8 +397,8 @@ parameter postion of a gate application." (quil::parse-pragma (quil::tokenize (cl:with-output-to-string (out) - (cl:write-string "PRAGMA ") - (cl:write-string pstring)))))) + (cl:write-string "PRAGMA " out) + (cl:write-string pstring out)))))) ((macro:Label s) (lisp Instruction (s) @@ -472,8 +472,8 @@ parameter postion of a gate application." (quil::parse-pragma (quil::tokenize (cl:with-output-to-string (out) - (cl:write-string "PRAGMA ") - (cl:write-string pstring)))))) + (cl:write-string "PRAGMA " out) + (cl:write-string pstring out)))))) ((ast:DeclareMem descriptor) (raw-mem-descriptor descriptor)) From 0a202dab1952be93661c28d7f40687086888aad9 Mon Sep 17 00:00:00 2001 From: Colin O'Keefe Date: Thu, 26 Sep 2024 10:13:01 -0700 Subject: [PATCH 6/7] system rename --- cl-quil.asd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cl-quil.asd b/cl-quil.asd index 7dcc74c9..6db28a3e 100644 --- a/cl-quil.asd +++ b/cl-quil.asd @@ -163,8 +163,8 @@ (:file "print-program") (:file "initialize-standard-gates"))) -(asdf:defsystem #:coalton-quil/ast - :description "Coalton implementation cl-quil/ast" +(asdf:defsystem #:cl-quil/coalton/ast + :description "Coalton implementation src/cl-quil/ast.lisp and related types" :depends-on (#:cl-quil #:coalton) :pathname "src/coalton/ast/" :serial t From 8ab626d51f031e1cc4c5f5b597e442f019fefa2e Mon Sep 17 00:00:00 2001 From: Colin O'Keefe Date: Thu, 26 Sep 2024 14:32:45 -0700 Subject: [PATCH 7/7] removed spurious source file --- src/coalton/ast/raw.lisp | 495 --------------------------------------- 1 file changed, 495 deletions(-) delete mode 100644 src/coalton/ast/raw.lisp diff --git a/src/coalton/ast/raw.lisp b/src/coalton/ast/raw.lisp deleted file mode 100644 index 7c8f62af..00000000 --- a/src/coalton/ast/raw.lisp +++ /dev/null @@ -1,495 +0,0 @@ -(defpackage #:quil/ast/raw - (:use #:coalton) - (:documentation "Native Cl-QUIL and CL-QUIL.FRONTEND Types") - (:import-from #:coalton-library/classes #:map) - (:local-nicknames - (#:quil #:cl-quil.frontend) - (#:ast #:quil/ast/unresolved))) - -(in-package #:quil/ast/raw) - -(named-readtables:in-readtable coalton:coalton) - -;;; HELPERS TO COPE WITH RESOLVING ARITHMETIC EXPRESSIONS TO THEIR -;;; "RAW" CL-QUIL REPRESENTATIONS - -(cl:defun get-expr-params (expr) - "Helper function. Returns a list suitable for filling the PARAMETERS -slot of a DELAYED-EXPRESSION instance." - (cl:etypecase expr - (cl:null cl:nil) - (quil:param (cl:list expr)) - (quil:constant cl:nil) - (quil:delayed-expression - (quil:delayed-expression-params expr)))) - -(cl:defun get-expr-lambda-params (expr) - "Helper function. Returns a list of symbols suitable for filling the -LAMBDA-PARAMETERS slot of a DELAYED-EXPRESSION instance" - (cl:etypecase expr - (cl:null cl:nil) - (quil:param (cl:list (cl:make-symbol (quil:param-name expr)))) - (quil:constant cl:nil) - (quil:delayed-expression - (quil:delayed-expression-lambda-params expr)))) - -(cl:defun get-expr-exprs (expr) - "Helper function, returns a value that can appear as a -sub-expression (a SEXP) in a DELAYED-EXPRESSIONS instance's EXPRESSION -slot." - (cl:etypecase expr - (cl:null cl:nil) - (quil:param (cl:make-symbol (quil:param-name expr))) - (quil:constant (quil:constant-value expr)) - (quil:delayed-expression - (quil:delayed-expression-expression expr)))) - -(cl:defmacro combine-params (str arg1 cl:&optional arg2) - "Generates a form to produce a DELAYED-EXPRESSION out of the values of -forms ARG1 and ARG2, which may be anything that can appear in a -parameter postion of a gate application." - (cl:let* ((var1 (cl:gensym "VAR")) - (var2 (cl:gensym "VAR")) - (vars (cl:list var1 var2)) - (new-params (cl:gensym "PARAMS")) - (new-lambda-params (cl:gensym "LAMBDAPARAMS")) - (new-expression (cl:gensym "EXPR")) - (op (cl:gensym "OP"))) - `(let ((,var1 (expr-to-raw ,arg1)) - (,var2 ,(cl:if arg2 - `(expr-to-raw ,arg2) - `(lisp Param () cl:nil)))) - (lisp Param ,(cl:if (cl:stringp str) vars (cl:cons str vars)) - (cl:let* ((,op (cl:intern (cl:string-upcase ,str) :common-lisp)) - (,new-params - (cl:union (get-expr-params ,var1) - (get-expr-params ,var2) - :test 'cl:equalp)) - (,new-lambda-params - (cl:union (get-expr-lambda-params ,var1) - (get-expr-lambda-params ,var2) - :test 'cl:string=)) - (,new-expression - (cl:list* ,op - (get-expr-exprs ,var1) - (cl:if ,var2 - (cl:list - (get-expr-exprs ,var2)) - cl:nil)))) - (quil:make-delayed-expression - ,new-params ,new-lambda-params ,new-expression)))))) - - -;; HELPER MACROS TO INSTANTIATE CLASSICAL MEMORY OPERATION INSTRUCTIONS - -(cl:defmacro unary-classical-op (name ref) - (cl:let ((rawvar (cl:gensym))) - `(let ((,rawvar (raw-ref-arg ,ref))) - (lisp Instruction (,rawvar) - (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) - :target ,rawvar))))) - -(cl:defmacro binary-classical-op (name left right) - (cl:let ((lvar (cl:gensym)) - (rvar (cl:gensym))) - `(let ((,lvar (raw-ref-arg ,left)) - (,rvar (raw-ref-arg ,right))) - (lisp Instruction (,lvar ,rvar) - (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) - :left ,lvar :right ,rvar))))) - -(cl:defmacro ternary-classical-op (name target left right) - (cl:let ((tvar (cl:gensym)) - (lvar (cl:gensym)) - (rvar (cl:gensym))) - `(let ((,tvar (raw-ref-arg ,target)) - (,lvar (raw-ref-arg ,left)) - (,rvar (raw-ref-arg ,right))) - (lisp Instruction (,tvar ,lvar ,rvar) - (cl:make-instance (cl:find-symbol ,name :cl-quil.frontend) - :left ,lvar :right ,rvar :target ,tvar))))) - - - -(coalton-toplevel - - (repr :native cl-quil:quil-type) - (define-type QuilType) - - (declare raw-quil-type (ast:QuilType -> QuilType)) - (define (raw-quil-type qt) - (match qt - ((ast:QuilBit) (lisp QuilType () quil:quil-bit)) - ((ast:QuilOctet) (lisp QuilType () quil:quil-octet)) - ((ast:QuilInteger) (lisp QuilType () quil:quil-integer)) - ((ast:QuilReal) (lisp QuilType () quil:quil-real)))) - - (repr :native cl-quil:parsed-program) - (define-type Program) - - (repr :native (cl:or cl-quil:qubit cl-quil:formal)) - (define-type QubitArg) - - (repr :native (cl:or cl-quil:formal cl-quil:memory-ref)) - (define-type RefArg) - - (repr :native cl-quil:memory-ref) - (define-type MRef) - - (declare ref-to-raw (ast:Ref -> Mref)) - (define (ref-to-raw (ast:Ref name loc)) - (lisp Mref (name loc) - (quil:mref name loc))) - - (repr :native (cl:or cl-quil:param - cl-quil.frontend:delayed-expression - cl-quil:constant cl:null)) - (define-type Param) - - (repr :native (cl:or cl-quil:instruction - cl-quil:memory-descriptor - cl-quil:jump-target - cl-quil:gate-definition - cl-quil:circuit-definition)) - (define-type Instruction) - - ;; If non-literal numbertypes are supported, this should be altered - ;; to be something like (real :num, complex :num => ..) - ;; and the Const case be handled to interperet the :num to a type - ;; that quilc can already handle - (declare expr-to-raw (ast:Expr :num -> Param)) - (define (expr-to-raw e) - (match e - ((ast:Add e1 e2) (combine-params "+" e1 e2)) - - ((ast:Sub e1 e2) (combine-params "-" e1 e2)) - - ((ast:Mul e1 e2) (combine-params "*" e1 e2)) - - ((ast:Div e1 e2) (combine-params "/" e1 e2)) - - ((ast:Pow e1 e2) (combine-params "EXPT" e1 e2)) - - ((ast:Neg e1) (combine-params "-" e1)) - - ((ast:Const e) - (lisp Param (e) - (quil:constant e))) - - ((ast:RefExpr rf) - (let ((rr (ref-to-raw rf))) - (lisp Param (rr) - (quil:make-delayed-expression cl:nil cl:nil rr)))) - - ((ast:Var name) - (lisp Param (name) - (quil:param name))) - - ((ast:Call name e) - (combine-params name e)))) - - (declare arg-to-raw ((ast:MaybeFormal Ufix) -> QubitArg)) - (define (arg-to-raw a) - (match a - ((ast:Actual qb) (lisp QubitArg (qb) (quil:qubit qb))) - ((ast:Formal name) (lisp QubitArg (name) (quil:formal name))))) - - (declare raw-gate-application - (String -> (List (ast:Expr :num)) -> (List (ast:MaybeFormal Ufix)) -> Instruction)) - (define (raw-gate-application name params args) - (let ((params* (map expr-to-raw params)) - (args* (map arg-to-raw args))) - (lisp Instruction (name params* args*) - (cl:make-instance 'quil:unresolved-application - :operator (quil:named-operator name) - :parameters params* - :arguments args*)))) - - - (declare raw-classical-op (ast:ClassicalOperation -> Instruction)) - (define (raw-classical-op op) - (match op - ((ast:NegOp r) - (unary-classical-op "CLASSICAL-NEGATE" r)) - ((ast:NotOp r) - (unary-classical-op "CLASSICAL-NOT" r)) - - ((ast:MoveOp a b) - (binary-classical-op "CLASSICAL-MOVE" a b)) - ((ast:ExchangeOp a b) - (binary-classical-op "CLASSICAL-EXCHANGE" a b)) - ((ast:ConvertOp a b) - (binary-classical-op "CLASSICAL-CONVERT" a b)) - ((ast:AndOp a b) - (binary-classical-op "CLASSICAL-AND" a b)) - ((ast:IOrOp a b) - (binary-classical-op "CLASSICAL-INCLUSIVE-OR" a b)) - ((ast:XOrOp a b) - (binary-classical-op "CLASSICAL-EXCLUSIVE-OR" a b)) - ((ast:AddOp a b) - (binary-classical-op "CLASSICAL-ADDITION" a b)) - ((ast:SubOp a b) - (binary-classical-op "CLASSICAL-SUBTRACTION" a b)) - ((ast:MulOp a b) - (binary-classical-op "CLASSICAL-MULTIPLICATION" a b)) - ((ast:DivOp a b) - (binary-classical-op "CLASSICAL-DIVISION" a b)) - - ((ast:LoadOp a b c) - (ternary-classical-op "CLASSICAL-LOAD" a b c)) - ((ast:StoreOp a b c) - (ternary-classical-op "CLASSICAL-STORE" a b c)) - ((ast:EqOp a b c) - (ternary-classical-op "CLASSICAL-EQUALITY" a b c)) - ((ast:GtOp a b c) - (ternary-classical-op "CLASSICAL-GREATER-THAN" a b c)) - ((ast:GeOp a b c) - (ternary-classical-op "CLASSICAL-GREATER-EQUAL" a b c)) - ((ast:LtOp a b c) - (ternary-classical-op "CLASSICAL-LESS-THAN" a b c)) - ((ast:LeOp a b c) - (ternary-classical-op "CLASSICAL-LESS-EQUAL" a b c)))) - - (declare raw-gate-def (String -> (ast:GateDef :num) -> Instruction)) - (define (raw-gate-def name gdef) - (match gdef - ((ast:PermuationGateDef vals) - (lisp Instruction (name vals) - (cl:make-instance 'quil:permutation-gate-definition - :name name :permutation vals :context cl:nil))) - - ((ast:ParameterizedGateDef params exprs) - (let ((exprs* (map expr-to-raw exprs))) - (lisp Instruction (name params exprs*) - (cl:make-instance 'quil:parameterized-gate-definition - :name name - :entries (cl:mapcar 'get-expr-exprs exprs*) - :parameters (cl:mapcar 'cl:make-symbol params))))) - - ((ast:StaticGateDef entries) - (lisp Instruction (name entries) - (cl:make-instance 'quil:static-gate-definition - :name name - :entries entries))) - - ((ast:PauliSumGateDef terms params args) - (lisp Instruction (name terms params args) - (cl:make-instance 'quil:exp-pauli-sum-gate-definition - :name name - :arguments (cl:mapcar #'quil:formal args) - :parameters (cl:mapcar 'cl:make-symbol params) - :terms (cl:loop :for term :in terms - :collect (quil:make-pauli-term - :pauli-word (ast:pauli-term-word term) - :prefactor (ast:pauli-term-prefactor term) - :arguments (cl:mapcar #'quil:formal (ast:pauli-term-arguments term))))))))) - - - (declare raw-ref-arg (ast:MaybeFormal ast:Ref -> RefArg)) - (define (raw-ref-arg ja) - (match ja - ((ast:Formal name) - (lisp RefArg (name) - (quil:formal name))) - ((ast:Actual (ast:Ref name loc)) - (lisp RefArg (name loc) - (quil:mref name loc))))) - - (declare instr-to-raw (ast:Instruction :num -> Instruction)) - (define (instr-to-raw instr) - (match instr - ((ast:ApplyGate g) (gate-to-raw g)) - - ((ast:Include name) - (lisp Instruction (name) - (cl:make-instance 'quil:include :pathname name))) - - ((ast:Pragma pstring) - (lisp Instruction (pstring) - (quil::parse-pragma - (quil::tokenize - (cl:with-output-to-string (out) - (cl:write-string "PRAGMA ") - (cl:write-string pstring)))))) - - ((ast:Memory name type length sharing offsets) - (lisp instruction (name type length sharing offsets) - (quil:make-memory-descriptor - :name name - :type (raw-quil-type type) - :length length - :sharing-parent sharing - :sharing-offset-alist - (cl:loop :for offset :in offsets - :collect (cl:cons - (raw-quil-type (ast:offset-type offset)) - (ast:offset-amount offset)))))) - - ((ast:GateDefinition name gdef) - (raw-gate-def name gdef)) - - ((ast:CircuitDefinition name params args body) - (let ((instrs (map instr-to-raw body))) - (lisp Instruction (name params args instrs) - (cl:make-instance 'quil:circuit-definition - :name name - :parameters (cl:mapcar 'quil:param params) - :arguments (cl:mapcar 'quil:formal args) - :body instrs)))) - - ((ast:ApplyOp op) - (raw-classical-op op)) - - ((ast:Label l) - (lisp Instruction (l) - (cl:make-instance 'quil:jump-target - :label (quil:label l)))) - - ((ast:Jump l) - (lisp Instruction (l) - (cl:make-instance 'quil:unconditional-jump - :label (quil:label l)))) - - ((ast:JumpWhen l a) - (lisp Instruction (l a) - (cl:make-instance 'quil:jump-when - :label (quil:label l) - :address (raw-ref-arg a)))) - - ((ast:JumpUnless l a) - (lisp Instruction (l a) - (cl:make-instance 'quil:jump-unless - :label (quil:label l) - :address (raw-ref-arg a)))) - - ((ast:Noop) - (lisp Instruction () - (cl:make-instance 'quil:no-operation))) - - ((ast:Halt) - (lisp Instruction () - (cl:make-instance 'quil:halt))) - - - ((ast:Wait) - (lisp Instruction () - (cl:make-instance 'quil:wait))) - - ((ast:ResetAll) - (lisp Instruction () - (cl:make-instance 'quil:reset))) - - ((ast:Reset qb) - (let ((qb* (arg-to-raw qb))) - (lisp Instruction (qb*) - (cl:make-instance 'quil:reset-qubit :target qb*)))) - - ((ast:Measure qb loc) - (let ((qb* (arg-to-raw qb)) - (loc* (raw-ref-arg loc))) - (lisp Instruction (qb* loc*) - (cl:make-instance 'quil:measure :address loc* :qubit qb*)))) - - - ((ast:MeasureDiscard qb) - (let ((qb* (arg-to-raw qb))) - (lisp Instruction (qb*) - (cl:make-instance 'quil:measure-discard :qubit qb*)))))) - - (declare gate-to-raw (ast:Gate :num -> Instruction)) - (define (gate-to-raw g) - (match g - ((ast:Gate name params args) - (raw-gate-application name params args)) - ((ast:I a) - (raw-gate-application "I" nil (make-list a))) - ((ast:X a) - (raw-gate-application "X" nil (make-list a))) - ((ast:Y a) - (raw-gate-application "Y" nil (make-list a))) - ((ast:Z a) - (raw-gate-application "Z" nil (make-list a))) - ((ast:H a) - (raw-gate-application "H" nil (make-list a))) - ((ast:S a) - (raw-gate-application "S" nil (make-list a))) - ((ast:T a) - (raw-gate-application "T" nil (make-list a))) - ((ast:RX e a) - (raw-gate-application "RX" (make-list e) (make-list a))) - ((ast:RY e a) - (raw-gate-application "RY" (make-list e) (make-list a))) - ((ast:RZ e a) - (raw-gate-application "RZ" (make-list e) (make-list a))) - ((ast:PHASE e a) - (raw-gate-application "PHASE" (make-list e) (make-list a))) - ((ast:CNOT a b) - (raw-gate-application "CNOT" nil (make-list a b))) - ((ast:CZ a b) - (raw-gate-application "CZ" nil (make-list a b))) - ((ast:SWAP a b) - (raw-gate-application "SWAP" nil (make-list a b))) - ((ast:ISWAP a b) - (raw-gate-application "ISWAP" nil (make-list a b))) - ((ast:SQISWAP a b) - (raw-gate-application "SQISWAP" nil (make-list a b))) - ((ast:CSWAP a b c) - (raw-gate-application "CSWAP" nil (make-list a b c))) - ((ast:CCNOT a b c) - (raw-gate-application "CCNOT" nil (make-list a b c))) - ((ast:PSWAP e a b) - (raw-gate-application "PSWAP" (make-list e) (make-list a b))) - ((ast:PISWAP e a b) - (raw-gate-application "PISWAP" (make-list e) (make-list a b))) - ((ast:XY e a b) - (raw-gate-application "XY" (make-list e) (make-list a b))) - ((ast:CAN alpha beta gamma a b) - (raw-gate-application "CAN" - (make-list alpha beta gamma) - (make-list a b))) - ((ast:BLOCH a b c q) - (raw-gate-application "BLOCH" (make-list a b c) (make-list q))) - ((ast:DAGGER g) - (let ((gapp (gate-to-raw g))) - (lisp Instruction (gapp) - (cl:setf (quil:application-operator gapp) - (quil:dagger-operator (quil:application-operator gapp))) - gapp))) - ((ast:CONTROLLED q g) - (let ((gapp (gate-to-raw g)) - (rawq (arg-to-raw q))) - (lisp Instruction (gapp rawq) - (cl:setf (quil:application-operator gapp) - (quil:controlled-operator (quil:application-operator gapp))) - (cl:setf (quil:application-arguments gapp) - (cons rawq - (quil:application-arguments gapp))) - gapp))) - - ((ast:FORKED ctl ps g) - (let ((gapp (gate-to-raw g)) - (rawctl (arg-to-raw ctl)) - (rawps (map expr-to-raw ps))) - (lisp Instruction (gapp rawctl rawps) - (cl:setf (quil:application-operator gapp) - (quil:forked-operator (quil:application-operator gapp))) - (cl:setf (quil:application-parameters gapp) - (cl:nconc rawps (quil:application-parameters gapp))) - (cl:setf (quil:application-arguments gapp) - (cons rawctl (quil:application-arguments gapp))) - gapp))))) - - - (declare build-resolved-program (List (ast:Instruction :num) -> Program)) - (define (build-resolved-program instrs) - (let ((raw-instrs (map instr-to-raw instrs))) - (lisp Program (raw-instrs) - (cl:let ((pp (quil:resolve-objects - (quil::raw-quil-to-unresolved-program - raw-instrs)))) - (cl:dolist (xform quil::*standard-post-parsing-transforms*) - (cl:setf pp (quil:transform xform pp))) - pp)))) - - ;;eof - )