├── .gitignore ├── doc ├── notes │ └── compilation-strategies.pdf └── bnf.org ├── src ├── reference │ ├── package.lisp │ └── ref.lisp ├── log │ ├── package.lisp │ └── log.lisp ├── stepper │ ├── define.lisp │ └── package.lisp ├── util │ ├── package.lisp │ ├── bit.lisp │ └── utils.lisp ├── spec │ ├── emit.lisp │ ├── meta.lisp │ ├── term-op.lisp │ ├── type-op.lisp │ ├── type.lisp │ ├── storage.lisp │ ├── data-traversal.lisp │ ├── package.lisp │ └── global.lisp ├── stack │ ├── package.lisp │ └── stack.lisp ├── package.lisp ├── closure │ ├── package.lisp │ ├── closure.lisp │ └── dependency.lisp ├── pass │ ├── evaluate-body.lisp │ ├── dependencies.lisp │ ├── redundant-let.lisp │ ├── array.lisp │ ├── pipeline.lisp │ ├── extract.lisp │ ├── anf.lisp │ ├── pack.lisp │ ├── package.lisp │ └── expand.lisp ├── vampir │ ├── package.lisp │ ├── vampir.lisp │ └── spec.lisp ├── intermediate │ ├── primitive-global.lisp │ ├── package.lisp │ ├── new-terms.lisp │ └── spec.lisp └── typechecker │ ├── intro.lisp │ ├── size.lisp │ ├── package.lisp │ └── types.lisp ├── Makefile ├── test ├── evaluate-body.lisp ├── dependencies.lisp ├── package.lisp ├── alu.lisp ├── spec.lisp ├── expand.lisp ├── typecheck.lisp ├── packing.lisp ├── vampir.lisp ├── run-tests.lisp ├── stack.lisp ├── anf.lisp ├── pass.lisp ├── relocation.lisp └── step.lisp ├── clpmfile ├── alu ├── package.lisp ├── prelude.lisp └── example.lisp ├── app └── main.lisp ├── README.org └── alu.asd /.gitignore: -------------------------------------------------------------------------------- 1 | \#*# 2 | .[#]*[#] 3 | *.*~ 4 | *.fasl 5 | *.*fsl 6 | *.*fas -------------------------------------------------------------------------------- /doc/notes/compilation-strategies.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/anoma/alucard/HEAD/doc/notes/compilation-strategies.pdf -------------------------------------------------------------------------------- /src/reference/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:alu.reference 2 | (:documentation "Provides a mutable reference, that allows pass by 3 | reference semantics in CL.") 4 | (:use #:cl) 5 | (:export :ref :ref-p :!)) 6 | 7 | -------------------------------------------------------------------------------- /src/log/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:alu.log 2 | (:documentation "Provides reporting functionality to the language") 3 | (:local-nicknames (:spc :alu.spec)) 4 | (:shadow :error) 5 | (:use #:common-lisp #:serapeum) 6 | (:export 7 | :report 8 | :mode 9 | :*mode* 10 | :error 11 | :data)) 12 | -------------------------------------------------------------------------------- /src/stepper/define.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:alu.stepper.define) 2 | 3 | (defmacro defun (name lambda-list &rest body &environment env) 4 | (destructuring-bind (decs body) (step:split-declaration body) 5 | `(cl:defun ,name ,lambda-list 6 | ,@decs 7 | (stack:with-section ,name 8 | ,@(step:body body env))))) 9 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | make clean || true 3 | ros run --load "alu.asd" --eval "(progn (load \"alu.asd\") (make-system))" 4 | 5 | install: 6 | make clean || true 7 | make all 8 | mkdir -p '${HOME}/.local/bin/' 9 | mv "./build/alu.image" '${HOME}/.local/bin/' 10 | 11 | clean: 12 | rm "./build/alu.image" 13 | 14 | uninstall: 15 | rm '${HOME}/.local/bin/alu.image' 16 | -------------------------------------------------------------------------------- /src/reference/ref.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.reference) 2 | 3 | (defstruct ref contents) 4 | 5 | (defun ref (x) 6 | "Creates a reference out of x" 7 | (make-ref :contents x)) 8 | 9 | (defun ! (ref) 10 | "Grabs the contents of a reference" 11 | (ref-contents ref)) 12 | 13 | (defun (setf !) (x ref) 14 | "sets the reference value to x" 15 | (setf (ref-contents ref) x)) 16 | -------------------------------------------------------------------------------- /test/evaluate-body.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (def-suite alucard.evaluate-body 4 | :description "Test behavior related to adding to the body") 5 | 6 | (in-suite alucard.evaluate-body) 7 | 8 | (test eval:evaluate-circuit-body 9 | (let ((expected (list 5 6 7))) 10 | (is (equalp expected 11 | (alu.pass.evaluate-body:evaluate-circuit-body 12 | `(progn (emit:instruction 5) 13 | (emit:instruction 6) 14 | (emit:instruction 7))))))) 15 | -------------------------------------------------------------------------------- /clpmfile: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: common-lisp; -*- 2 | (:api-version "0.4") 3 | 4 | (:source "quicklisp" 5 | :url "https://beta.quicklisp.org/dist/quicklisp.txt" 6 | :type :quicklisp) 7 | 8 | (:asd "alu.asd") 9 | 10 | (:github "fiveam" 11 | :path "lispci/fiveam" 12 | ;; :branch "master" 13 | :commit "e11dee752a8f59065033ef9d60641d4a2f1e8379") 14 | 15 | ;; (:github "sycamore" 16 | ;; :path "ndantam/sycamore" 17 | ;; :branch "master") 18 | 19 | (:github "serapeum" 20 | :path "ruricolist/serapeum" 21 | :commit "d2985f5e42df11f0e3063625b8432f0a9eca912f") 22 | -------------------------------------------------------------------------------- /src/util/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:alu.utils 2 | (:documentation "provides the utility functions for the Alucard project") 3 | (:shadow #:deftype) 4 | (:use #:common-lisp #:serapeum) 5 | (:export 6 | :symbol-to-keyword 7 | :hash-compare 8 | :sycamore-plist-symbol-map 9 | :sycamore-symbol-map-plist 10 | :copy-instance 11 | 12 | ;; Alist Helpers 13 | :alist-values 14 | :leaf-alist-keys 15 | :nested-alist-keys 16 | 17 | ;; Bit packing functionality 18 | :sequence-to-number 19 | :string-to-number 20 | :string-to-bit-array 21 | :char-to-bit-array)) 22 | -------------------------------------------------------------------------------- /src/spec/emit.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.spec.emit) 2 | 3 | (defparameter *circuit-body* (list nil)) 4 | 5 | (defmacro with-circuit-body (init-body &body body) 6 | "Creates a fresh circuit body" 7 | `(progn (let ((*circuit-body* ,init-body)) 8 | ,@body) 9 | (setf ,init-body (remove-if #'null ,init-body)) 10 | ,init-body)) 11 | 12 | (defun instruction (term) 13 | "Adds the given term to the circuit body. This adds the value to the 14 | last slot of the given body" 15 | (setf (cdr *circuit-body*) (list term) 16 | *circuit-body* (cdr *circuit-body*))) 17 | -------------------------------------------------------------------------------- /src/stepper/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:alu.stepper 2 | (:documentation "Provides a code walker for CL that can instrument 3 | Stack trace information.") 4 | (:shadow #:step #:single) 5 | (:use #:common-lisp #:serapeum) 6 | (:local-nicknames (#:stack #:alu.stack)) 7 | (:export #:single #:body #:mode #:*mode* #:split-declaration)) 8 | 9 | (defpackage #:alu.stepper.define 10 | (:documentation "Provides custom definers that shadow CL base definers") 11 | (:shadow #:defun) 12 | (:use #:common-lisp #:serapeum) 13 | (:local-nicknames (#:step #:alu.stepper) 14 | (#:stack #:alu.stack)) 15 | (:export #:defun)) 16 | -------------------------------------------------------------------------------- /src/spec/meta.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.spec) 2 | 3 | (defclass stack-mixin () 4 | ((stack :initform (stack:get) 5 | :accessor stack)) 6 | (:documentation 7 | "Provides the service of getting the stack to the given instruction")) 8 | 9 | (defclass meta-mixin (stack-mixin) () 10 | (:documentation 11 | "Provides out the service of all meta information. Thus we define out: 12 | 13 | stack-mixin service")) 14 | 15 | (defgeneric copy-meta (obj1 obj2) 16 | (:method-combination progn) 17 | (:documentation "copies meta data from `obj1' into `obj2'")) 18 | 19 | (defmethod copy-meta progn ((obj1 stack-mixin) (obj2 stack-mixin)) 20 | (setf (stack obj2) (stack obj1)) 21 | obj2) 22 | 23 | (defmethod copy-meta progn ((obj1 number) (obj2 stack-mixin)) 24 | obj2) 25 | -------------------------------------------------------------------------------- /src/stack/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:alu.stack 2 | (:documentation "provides a custom stack mechanism and a way to 3 | define and promote functions to automatically push and pull from the 4 | stack when possible. Further, operations operate on a global dynamic 5 | variable and offer rebinding and passing in capabilities.") 6 | (:local-nicknames (:ref :alu.reference)) 7 | (:shadow :push :pop :get :cdr :cons) 8 | (:use #:common-lisp #:serapeum) 9 | (:export 10 | ;; Mutable interface 11 | :push :pop :get :new 12 | ;; Functional Interface 13 | :cons :cdr 14 | :emptyp 15 | :cdr-current-section 16 | ;; functional getters 17 | :stack 18 | :current-section 19 | :name 20 | ;; Helper Macros 21 | :with-empty-stack 22 | :with-section 23 | :*stack*)) 24 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | 2 | ;; see https://gist.github.com/phoe/2b63f33a2a4727a437403eceb7a6b4a3 3 | ;; for an argument on local-nicknames flag for defpackage, and which 4 | ;; compilers support the non standard feature. 5 | ;; https://github.com/phoe/trivial-package-local-nicknames 6 | (defpackage #:alu 7 | (:documentation "provides the Alucard VAMP-IR DSL") 8 | (:shadow #:deftype #:def #:coerce #:get #:array) 9 | (:use #:common-lisp #:serapeum) 10 | (:local-nicknames (:util :alu.utils) 11 | (:spc :alu.spec) 12 | (:storage :alu.storage) 13 | (:emit :alu.spec.emit)) 14 | (:export #:deftype #:defcircuit #:def #:defprimitive #:defprimitive-type 15 | #:entry-point #:coerce #:check #:get #:array #:to-array 16 | #:with-constraint)) 17 | -------------------------------------------------------------------------------- /test/dependencies.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (def-suite alucard.dependencies 4 | :description "Test dependency tracking") 5 | 6 | (in-suite alucard.dependencies) 7 | 8 | (test circuit-dependency 9 | (let ((expected-deps (sort (list :* :+ :=) #'util:hash-compare)) 10 | (ran (sort (dep:track-circuit-deps 11 | (storage:lookup-function :constrain)) 12 | #'util:hash-compare))) 13 | (is (equalp expected-deps 14 | ran)))) 15 | 16 | (test circuit-dependency* 17 | (let ((expected-deps (sort (list :constrain :* :+ :=) #'util:hash-compare)) 18 | (ran (sort (dep:track-circuit-deps* 19 | (storage:lookup-function :use-constrain)) 20 | #'util:hash-compare))) 21 | (is (equalp expected-deps ran)))) 22 | -------------------------------------------------------------------------------- /src/closure/package.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:alu.closure 3 | (:documentation "Provides a simple closure structure") 4 | (:local-nicknames (:syc :sycamore) 5 | (:util :alu.utils)) 6 | (:shadow #:remove #:length) 7 | (:use #:common-lisp #:serapeum) 8 | (:export 9 | :typ 10 | :allocate 11 | :from-plist 12 | :from-alist 13 | :insert 14 | :length 15 | :lookup 16 | :remove 17 | :keys)) 18 | 19 | (defpackage #:alu.closure.dependency 20 | (:documentation "Provides a dependency closure that shows dependency 21 | between values") 22 | (:shadow #:remove #:reverse #:length) 23 | (:local-nicknames (:syc #:sycamore) 24 | (:util #:alu.utils) 25 | (:closure #:alu.closure)) 26 | (:use #:common-lisp #:serapeum) 27 | (:export 28 | :typ 29 | :allocate 30 | :determined-by 31 | :lookup 32 | :solved-for 33 | :solved-for* 34 | :get-solved 35 | :dump-solved 36 | :add-dependencies 37 | :determine-each-other)) 38 | -------------------------------------------------------------------------------- /doc/bnf.org: -------------------------------------------------------------------------------- 1 | #+begin_src bnf 2 | ;; Top Level 3 | 4 | defcircuit ::= (defcircuit (* ?) *) 5 | 6 | deftype ::= (deftype () *) 7 | 8 | field ::= ( ) 9 | 10 | type-field ::= ( ) 11 | 12 | return ::= (return ) 13 | 14 | privacy ::= public | private 15 | 16 | ;; Expression 17 | 18 | expression ::= 19 | | 20 | | 21 | | 22 | | 23 | | 24 | 25 | def ::= (def (*) *) 26 | 27 | check ::= (check ) 28 | 29 | coerce ::= (coerce ) 30 | 31 | application ::= ( *) 32 | 33 | arr-get ::= (get ) 34 | 35 | bind ::= ( ) 36 | 37 | expression ::= 38 | 39 | type ::= | ( *) 40 | 41 | symbol ::= 42 | #+end_src 43 | -------------------------------------------------------------------------------- /src/pass/evaluate-body.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.pass.evaluate-body) 2 | 3 | (-> evaluate-and-cache-body (ir:circuit) list) 4 | (defun evaluate-and-cache-body (circuit) 5 | "This function evals the given circuit body and returns the cached 6 | arguments" 7 | (values 8 | (if (properly-chachedp circuit) 9 | (ir:exec circuit) 10 | (let ((exec-body (evaluate-circuit-body (ir:body circuit)))) 11 | (setf (ir:exec circuit) exec-body) 12 | exec-body)))) 13 | 14 | (-> evaluate-circuit-body (list) list) 15 | (defun evaluate-circuit-body (frozen-term) 16 | ;; need a cons to start with, so make a cons 17 | (let ((new-body (list nil))) 18 | (emit:with-circuit-body new-body 19 | ;; we have actual frozen code, we must eval! 20 | (eval frozen-term)))) 21 | 22 | (-> properly-chachedp (ir:circuit) boolean) 23 | (defun properly-chachedp (circuit) 24 | "checks if the circuit's execution body is properly cached" 25 | (declare (ignore circuit)) 26 | ;; Currently we have no good tracking, so just return that it is not 27 | ;; cached! 28 | nil) 29 | 30 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :alu-test 2 | (:mix #:cl #:alu.prelude #:fiveam #:serapeum) 3 | (:shadow #:time) 4 | (:local-nicknames (:util :alu.utils) 5 | (:ir :alu.ir) 6 | (:storage :alu.storage) 7 | (:emit :alu.spec.emit) 8 | (:anf :alu.pass.anf) 9 | (:closure :alu.closure) 10 | (:expand :alu.pass.expanded) 11 | (:relocate :alu.pass.relocation) 12 | (:vamp :alu.vampir) 13 | (:dep :alu.pass.dependencies) 14 | (:eval :alu.pass.evaluate-body) 15 | (:check :alu.typechecker) 16 | (:pass :alu.pass) 17 | (:pack :alu.pass.pack) 18 | (:pipeline :alu.pipeline) 19 | (:vspc :alu.vampir.spec) 20 | (:prld :alu.prelude) 21 | (:ref :alu.reference) 22 | (:stack :alu.stack) 23 | (:step :alu.stepper) 24 | (:step.def :alu.stepper.define)) 25 | (:export #:run-tests)) 26 | 27 | (in-package :alu-test) 28 | -------------------------------------------------------------------------------- /src/spec/term-op.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.spec.term-op) 2 | 3 | 4 | (defun add (&rest arguments) 5 | (spc:make-application 6 | :function (spc:make-reference :name :+) 7 | :arguments arguments)) 8 | 9 | (defun times (&rest arguments) 10 | (spc:make-application 11 | :function (spc:make-reference :name :*) 12 | :arguments arguments)) 13 | 14 | (defun = (&rest arguments) 15 | (spc:make-application 16 | :function (spc:make-reference :name :=) 17 | :arguments arguments)) 18 | 19 | (defun exp (&rest arguments) 20 | (spc:make-application 21 | :function (spc:make-reference :name :exp) 22 | :arguments arguments)) 23 | 24 | (defun coerce (type value) 25 | (spc:make-type-coerce 26 | :typ (spc:to-type-reference-format type) 27 | :value value)) 28 | 29 | (-> kind-of-pirmitive? (spc:reference (-> (spc:primitive) boolean)) boolean) 30 | (defun kind-of-pirmitive? (ref predicate) 31 | (let* ((looked (storage:lookup-function (spc:name ref)))) 32 | (etypecase-of (or spc:function-type null) looked 33 | ((or null spc:circuit) nil) 34 | (spc:primitive (funcall predicate looked))))) 35 | 36 | (-> void-reference? (spc:reference) boolean) 37 | (defun void-reference? (ref) 38 | (kind-of-pirmitive? ref (lambda (v) (eql :void (spc:name v))))) 39 | -------------------------------------------------------------------------------- /src/log/log.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.log) 2 | 3 | (deftype mode () 4 | "Determines the behavior of the " 5 | `(or (eql :report) (eql :error))) 6 | 7 | (defparameter *mode* 8 | :error 9 | "The mode in which the error reporter works in. 10 | :report Reports the error to the user, with the object being returned 11 | :error Reports the error to the user, with a simple error thrown") 12 | 13 | (define-condition error (cl:error) 14 | ((data :initarg :data 15 | :reader data))) 16 | 17 | (defun error (object-in-question cat message &rest args-to-message) 18 | "Reports Errors to the user" 19 | (let ((stack (ignore-errors (spc:stack object-in-question))) 20 | (message (apply #'format nil message args-to-message))) 21 | (v:error cat "~A~%[STACK]~%~A" message stack) 22 | (etypecase-of mode *mode* 23 | ((eql :report) object-in-question) 24 | ((eql :error) (cl:error 'error :data object-in-question))))) 25 | 26 | (defmethod v:format-message ((stream stream) (message v:message)) 27 | (format stream "~a~%[~5,a] ~{<~a>~}:~%~A" 28 | (local-time:format-timestring 29 | NIL (v:timestamp message) :format v:*timestamp-format*) 30 | (v:level message) 31 | (v:categories message) 32 | (v:format-message NIL (v:content message)))) 33 | -------------------------------------------------------------------------------- /src/vampir/package.lisp: -------------------------------------------------------------------------------- 1 | 2 | ;; Setup this package to extract 3 | (defpackage #:alu.vampir.spec 4 | (:documentation "The Vampir model specification") 5 | (:use #:common-lisp) 6 | (:shadow :=) 7 | (:local-nicknames (#:util #:alu.utils) 8 | (#:ser #:serapeum)) 9 | (:export 10 | ;; New Top Level Term Variants Defined 11 | :statement 12 | :constraint 13 | :expression 14 | :normal-form 15 | :primitive 16 | 17 | ;; New Term Lists Defined 18 | :normal-form-list 19 | :constraint-list 20 | ;; Term ADT Constructors Defined 21 | :alias :name :inputs :outputs :body 22 | :pub :wires 23 | :infix :op :lhs :rhs 24 | :application :func :arguments 25 | :bind :names :value 26 | :equality :lhs :rhs 27 | :wire :var 28 | :constant :const 29 | :tuple :wires 30 | 31 | ;; Constructors 32 | :make-alias :make-pub :make-infix :make-application :make-tuples 33 | :make-bind :make-equality :make-wire :make-constant)) 34 | 35 | (defpackage #:alu.vampir 36 | (:documentation "Provides a vampir representation") 37 | (:use #:common-lisp #:serapeum) 38 | (:shadow :=) 39 | (:local-nicknames (#:util #:alu.utils) 40 | (#:spc #:alu.vampir.spec)) 41 | (:export :extract)) 42 | 43 | -------------------------------------------------------------------------------- /src/intermediate/primitive-global.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.ir.primitive-global) 2 | 3 | (defclass prim-circuit () 4 | ((name :initarg :name 5 | :type keyword 6 | :accessor spc:name 7 | :documentation "Name of the circuit") 8 | ;; a list of constraints 9 | (arguments :initarg :arguments 10 | :type list 11 | :accessor spc:arguments 12 | :documentation "Arguments for the circuit, saved in a 13 | a list of `keyword'") 14 | (returns :initarg :returns 15 | :type list 16 | :accessor returns 17 | :documentation "The return output of a given circuit 18 | stored in a list of `keyword'") 19 | (body :initarg :body 20 | :accessor spc:body 21 | :documentation "The circuit logic"))) 22 | 23 | 24 | (defmethod print-object ((obj prim-circuit) stream) 25 | (with-accessors ((name spc:name) (ret returns) (bod spc:body) (arg spc:arguments)) obj 26 | (print-unreadable-object (obj stream :type t) 27 | (format stream "~A~{ ~A~^~} -> ~{~A~^ ~} =~%~A : ~A" name arg ret bod ret)))) 28 | 29 | (defun make-prim-circuit (&key name arguments returns body) 30 | (make-instance 'prim-circuit 31 | :name name 32 | :body body 33 | :returns returns 34 | :arguments arguments)) 35 | -------------------------------------------------------------------------------- /src/typechecker/intro.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.typechecker.intro) 2 | 3 | (-> intro (typing-context &rest keyword) typing-context) 4 | (defun intro (ctx &rest keys) 5 | (values 6 | (check:make-starting-hole keys ctx))) 7 | 8 | ;; TODO Finish 9 | (-> intro-maybe-solution (typing-context &rest t) typing-context) 10 | (defun intro-maybe-solution (ctx &rest keys) 11 | (let ((solutions (remove-if #'listp keys)) 12 | (holes (remove-if-not #'listp keys))) 13 | solutions 14 | (apply #'intro ctx holes))) 15 | 16 | ;; TODO Need an extra syntax for types to be given with the 17 | ;; introduction, since we may know them already. 18 | (defmacro with-intro ((new-context-name &rest names) context &body body) 19 | "With-intro introduces the names with gensym to the given context, 20 | binding the names for use in the body. 21 | 22 | EXAMPLE: 23 | 24 | ;; TODO, put some computation here from the code where I use this. 25 | (check:with-intro (ctx bar baz) context 26 | ctx)" 27 | `(let ,(mapcar (lambda (symbol) 28 | (let ((symbol-name 29 | (if (listp symbol) (car symbol) symbol))) 30 | `(,symbol-name (util:symbol-to-keyword 31 | (gensym (symbol-name ',symbol-name)))))) 32 | names) 33 | (let ((,new-context-name (intro ,context ,@names))) 34 | ,@body))) 35 | -------------------------------------------------------------------------------- /test/alu.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (def-suite alucard 4 | :description "Tests the alucard package") 5 | 6 | (in-suite alucard) 7 | 8 | (defun clone-hash-table (hash) 9 | (alexandria:plist-hash-table 10 | (alexandria:hash-table-plist hash))) 11 | 12 | (test deftype-works-as-expected 13 | (for-all ((name (gen-string)) 14 | (unroll-amount (gen-integer)) 15 | (field (gen-string))) 16 | (let ((storage:*types* (clone storage:*types*)) 17 | (name (intern name)) 18 | (field (intern field)) 19 | (keyword (intern name :keyword))) 20 | ;; we have to eval, as we are generating the values to go in the macro 21 | (eval `(alu:deftype (,name :unroll ,unroll-amount) () 22 | (,field (int 64)))) 23 | ;; did we add it to the table? 24 | (is (storage:lookup-type keyword)) 25 | ;; did we add the right amount of unrolling? 26 | (is (= unroll-amount 27 | (sycamore:tree-map-find (ir:options (storage:lookup-type keyword)) 28 | :unroll))) 29 | ;; did we add the field correctly 30 | (is (typep (sycamore:tree-map-find 31 | (ir:contents (ir:decl (storage:lookup-type keyword))) 32 | (util:symbol-to-keyword field)) 33 | 'ir:application)) 34 | ;; we add a global defn, check if it's there 35 | (is (fboundp name))))) 36 | -------------------------------------------------------------------------------- /alu/package.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:alu.prelude 2 | (:documentation "The Alu User pacakge") 3 | ;; we shouldn't use CL 4 | (:shadow #:range #:+ #:* #:= #:exp) 5 | (:local-nicknames (:util :alu.utils) 6 | (:spc :alu.spec) 7 | (:storage :alu.storage) 8 | (:emit :alu.spec.emit) 9 | (:pipeline :alu.pipeline) 10 | (:pass :alu.pass) 11 | (:def :alu.stepper.define)) 12 | (:mix #:alu #:common-lisp #:uiop) 13 | (:export #:+ #:* #:= #:exp #:deftype #:defcircuit #:def 14 | #:deflex #:bool #:entry-point #:coerce 15 | #:check #:get #:array #:to-array 16 | #:with-constraint 17 | #:vampir 18 | #:vampir-keyword 19 | #:quit 20 | #:start-swank 21 | #:start-slynk)) 22 | 23 | ;; we should probably move this to the very end of the load order, so 24 | ;; we can make it a very nice package for users to use. 25 | (uiop:define-package #:aluser 26 | (:documentation "The Alu User pacakge") 27 | (:shadow #:time) 28 | (:mix #:alu.stepper.define #:alu.prelude #:common-lisp) 29 | (:local-nicknames (:util :alu.utils) 30 | (:spc :alu.spec) 31 | (:storage :alu.storage) 32 | (:emit :alu.spec.emit) 33 | (:pipeline :alu.pipeline) 34 | (:pass :alu.pass)) 35 | (:reexport #:alu.prelude)) 36 | -------------------------------------------------------------------------------- /src/spec/type-op.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.spec.type-op) 2 | 3 | (-> kind-of-pirmitive? (spc:type-reference (-> (spc:primitive) boolean)) boolean) 4 | (defun kind-of-pirmitive? (ref predicate) 5 | (let* ((name-to-lookup 6 | (etypecase-of spc:type-reference ref 7 | (spc:reference-type (spc:name ref)) 8 | (spc:application (spc:name (spc:func ref))))) 9 | (looked (storage:lookup-type name-to-lookup))) 10 | (etypecase-of (or spc:type-storage null) looked 11 | ((or null spc:type-declaration) nil) 12 | (spc:primitive (funcall predicate looked))))) 13 | 14 | (-> record-reference? (spc:type-reference) boolean) 15 | (defun record-reference? (ref) 16 | (let* ((name-to-lookup 17 | (etypecase-of spc:type-reference ref 18 | (spc:reference-type (spc:name ref)) 19 | (spc:application (spc:name (spc:func ref))))) 20 | (looked (storage:lookup-type name-to-lookup))) 21 | (etypecase-of (or spc:type-storage null) looked 22 | (spc:type-declaration t) 23 | ((or null spc:primitive) nil)))) 24 | 25 | (-> primitive? (spc:type-reference) boolean) 26 | (defun primitive? (ref) 27 | "Checks if the " 28 | (kind-of-pirmitive? ref (constantly t))) 29 | 30 | (-> array-reference? (spc:type-reference) boolean) 31 | (defun array-reference? (ref) 32 | (kind-of-pirmitive? ref (lambda (v) (eql :array (spc:name v))))) 33 | 34 | (-> void-reference? (spc:type-reference) boolean) 35 | (defun void-reference? (ref) 36 | (kind-of-pirmitive? ref (lambda (v) (eql :void (spc:name v))))) 37 | 38 | (-> int-reference? (spc:type-reference) boolean) 39 | (defun int-reference? (ref) 40 | (kind-of-pirmitive? ref (lambda (v) 41 | (or (eql :int (spc:name v)) 42 | (eql :bool (spc:name v)))))) 43 | -------------------------------------------------------------------------------- /test/spec.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (def-suite alucard.format 4 | :description "Tests the alucard storage format") 5 | 6 | (in-suite alucard.format) 7 | 8 | (defclass test-mixin () 9 | ((foo :initarg :foo))) 10 | 11 | (defclass test-class (test-mixin ir:protect-slots-mixin) 12 | ((bar :initarg :bar) 13 | (baz :initarg :baz) 14 | ;; Must provide this, as allocation happens on the super class level ☹ 15 | (ir:protected :initform (make-hash-table :test #'eq) :allocation :class))) 16 | 17 | (ir:protect-slots 'test-class 'baz) 18 | 19 | ;; (slot-value (c2cl:class-prototype (find-class 'test)) 'protected) 20 | 21 | (test generic-data-considerations 22 | (let ((expected '((:bar . 5)))) 23 | (is 24 | (equalp expected 25 | (ir:direct-slots (make-instance 'test-class :foo 3 :bar 5 :baz 10)))))) 26 | 27 | 28 | (test record-creation-and-lookup-works 29 | (for-all ((name (gen-string)) 30 | (value (gen-integer))) 31 | (let ((keyword (intern name :keyword))) 32 | (is 33 | (equal (ir:lookup-record (ir:make-record :name :example keyword value) 34 | keyword) 35 | value))))) 36 | 37 | (test syntax-to-refernece-format 38 | (let ((applied (ir:to-type-reference-format '(int 64))) 39 | (nested (ir:to-type-reference-format '(int (int 64))))) 40 | (is (eq :INT 41 | (ir:name (ir:func applied)))) 42 | (is (= 64 43 | (car (ir:arguments applied)))) 44 | (is (eq :INT 45 | (ir:name (ir:func (car (ir:arguments nested)))))))) 46 | 47 | 48 | ;; Note for later, we can have exuastion 49 | ;; (match-of term (make-application :function :hi ) 50 | ;; ((application func) func)) 51 | 52 | ;; (typecase-of term 3 53 | ;; (number 54 | ;; 2) 55 | ;; (application 56 | ;; 2) 57 | ;; (otherwise 58 | ;; 2)) 59 | -------------------------------------------------------------------------------- /src/intermediate/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:alu.ir.new-terms 2 | (:documentation "Provides new constructors and types that can be 3 | used in the various IR's") 4 | (:local-nicknames (:util :alu.utils) 5 | (:spc :alu.spec)) 6 | (:use #:common-lisp #:serapeum) 7 | (:export 8 | ;; New Types Defined 9 | :bind 10 | :multiple-bind 11 | :standalone-ret 12 | ;; New Constructors Defined 13 | :make-bind 14 | :make-multi-ret 15 | :make-standalone-ret 16 | :make-multiple-bind)) 17 | 18 | (defpackage #:alu.ir.spec 19 | (:documentation "Provides various simplified term structures that 20 | has been through linearization") 21 | (:local-nicknames (:util :alu.utils) 22 | (:spc :alu.spec) 23 | (:terms :alu.ir.new-terms)) 24 | (:use #:common-lisp #:serapeum) 25 | (:export 26 | ;; New Term Variants Defined 27 | :linear-term 28 | :expanded-term 29 | :type-aware-term 30 | :fully-expanded-term 31 | :binders 32 | :starting-binders 33 | ;; New Term Lists Defined 34 | :type-aware-list 35 | :constraint-list 36 | :expanded-list 37 | :fully-expanded-list)) 38 | 39 | (defpackage #:alu.ir.primitive-global 40 | (:documentation "Provides a more low level representation of the 41 | global structure") 42 | (:local-nicknames (#:spc #:alu.spec)) 43 | (:use #:common-lisp #:serapeum) 44 | (:export 45 | :prim-circuit 46 | :returns 47 | :make-prim-circuit)) 48 | 49 | (uiop:define-package #:alu.ir 50 | (:documentation "Defines out all the various IR forms found in this 51 | directory, and adds their functionality to give an expanded `alu.spc' 52 | API. This also serves as the packages `spc' contribution.") 53 | (:use #:common-lisp #:serapeum) 54 | (:use-reexport 55 | :alu.spec 56 | :alu.ir.spec 57 | :alu.ir.new-terms 58 | :alu.ir.primitive-global)) 59 | -------------------------------------------------------------------------------- /test/expand.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (def-suite alucard.expand 4 | :description "Test the expanded argument functionality") 5 | 6 | (in-suite alucard.expand) 7 | 8 | ;; We sadly can't let over lambda, as the test gets ran later ☹ 9 | (test expansion-of-flat-arguments-work 10 | (let ((expanded-storage 11 | (expand:full-arguments-from-storage :arg-test-exp)) 12 | (arguments 13 | (ir:arguments (storage:lookup-function :arg-test-exp)))) 14 | 15 | ;; Tests begin here 16 | (is (eq (car arguments) (car expanded-storage)) 17 | "Bytes is a primitive type and should not be changed") 18 | (is (eq (cadr arguments) (cadr expanded-storage)) 19 | "int is a primtiive type and should not be changed") 20 | (is (not (eq (caddr arguments) (caddr expanded-storage))) 21 | "utx is not a primitve type and should be expanded properly") 22 | (is (typep (caddr expanded-storage) 'expand:expand) 23 | (format nil "UTX should turn into an expand type")) 24 | (is (alexandria:starts-with-subseq 25 | "UTX" 26 | (symbol-name (expand:original (caddr expanded-storage)))) 27 | "we preserve the name of the utx") 28 | (is (= 3 (length (expand:expanded (caddr expanded-storage)))) 29 | "The arguments should be expanded to 3 argument wide"))) 30 | 31 | (test expansion-of-output 32 | (let ((expanded-nested 33 | `((:plane . ,(expand:full-type-reference* 34 | (ir:make-type-reference :name :point))) 35 | (:time . ,(expand:full-type-reference* 36 | (ir:make-type-reference :name :point))))) 37 | (nested-lookup 38 | (expand:full-type-reference* (ir:make-type-reference :name :nested))) 39 | (arg-test-output-expansion 40 | (expand:full-return-values :arg-foo))) 41 | 42 | ;; Tests begin here 43 | (is (equalp expanded-nested nested-lookup) 44 | "Expansion of nested should expand twice") 45 | (is (equalp nested-lookup arg-test-output-expansion) 46 | "Expanding the output should have the same effect"))) 47 | -------------------------------------------------------------------------------- /src/pass/dependencies.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.pass.dependencies) 2 | 3 | (-> track-circuit-deps* (ir:function-type &optional sycamore:tree-set) list) 4 | (defun track-circuit-deps* (circuit &optional (exclusion-set 5 | (sycamore:tree-set 6 | #'util:hash-compare))) 7 | "This function works like `track-circuit-deps' however it recursively 8 | checks all functions" 9 | (labels ((recursively-expand (key-name) 10 | (unless (sycamore:tree-set-find exclusion-set key-name) 11 | ;; this technique doesn't work fully as we'd want a 12 | ;; reference to it. 13 | (sycamore:tree-set-insertf exclusion-set key-name) 14 | (let ((circuit (storage:lookup-function key-name))) 15 | (cons key-name 16 | (when circuit 17 | (track-circuit-deps* circuit exclusion-set))))))) 18 | (mapcan #'recursively-expand (track-circuit-deps circuit)))) 19 | 20 | (-> track-circuit-deps (ir:function-type) list) 21 | (defun track-circuit-deps (circuit) 22 | "This function gives out a list of any functions this function calls 23 | in a dependency chart" 24 | (values 25 | (etypecase-of ir:function-type circuit 26 | (ir:primitive nil) 27 | (ir:circuit (track-constraint-deps (alu.pass:linearize circuit)))))) 28 | 29 | ;; we assume that `pass:linearize' has been run 30 | (-> track-constraint-deps (ir:type-aware-list) list) 31 | (defun track-constraint-deps (constraint-list) 32 | (labels ((handle-term (term) 33 | (etypecase-of ir:term-type-manipulation term 34 | (ir:application 35 | (list (ir:name (ir:func term)))) 36 | ((or ir:term-normal-form ir:record ir:record-lookup 37 | ir:type-manipulation ir:array-forms) 38 | nil))) 39 | (handle-linear-term (constraint) 40 | (etypecase-of ir:expanded-term constraint 41 | (ir:bind (handle-term (ir:value constraint))) 42 | (ir:bind-constraint (track-constraint-deps (ir:value constraint))) 43 | (ir:standalone-ret nil)))) 44 | (mapcan #'handle-linear-term constraint-list))) 45 | -------------------------------------------------------------------------------- /test/typecheck.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (def-suite alucard.typecheck 4 | :description "Tests the type checker of alucard") 5 | 6 | (in-suite alucard.typecheck) 7 | 8 | (test type-equality-works-as-expected 9 | (is (check:type-equality (ir:to-type-reference-format '(int 32)) 10 | (ir:to-type-reference-format '(int 32)))) 11 | (is (check:type-equality (ir:to-type-reference-format '(int bar)) 12 | (ir:to-type-reference-format '(int bar)))) 13 | (is (null 14 | (check:type-equality (ir:to-type-reference-format '(int 64)) 15 | (ir:to-type-reference-format '(int 32)))))) 16 | 17 | 18 | (test find-no-data 19 | (is 20 | (null 21 | (alu.typechecker.check::find-type-info 22 | (ir:make-reference :name :foo) 23 | :foo 24 | (check::make-starting-hole 25 | '(:foo :bar) 26 | (make-instance 'check:typing-context)))))) 27 | 28 | (test running-the-type-checker 29 | (flet ((type-check (x) 30 | (pipeline:to-typecheck (storage:lookup-function x)))) 31 | (let ((old-categories (v:repl-categories))) 32 | (setf (v:repl-categories) nil) 33 | ;; Ignore categories 34 | (finishes (type-check :constrain)) 35 | (finishes (type-check :poly-check)) 36 | (finishes (type-check :array-lookup-equation)) 37 | (finishes (type-check :int-return)) 38 | (finishes (type-check :array-type-check)) 39 | (finishes (type-check :array-creation-check)) 40 | (finishes (type-check :array-from-data-check)) 41 | (finishes (type-check :array-from-data-check-consts)) 42 | (finishes (type-check :basic-unification)) 43 | (signals error (type-check :invalid-array-type-check)) 44 | (signals error (type-check :invalid-type-unification)) 45 | (signals error (type-check :invalid-record-lookup)) 46 | (signals error (type-check :invalid-record-lookup-type)) 47 | (signals error (type-check :manual-constraint)) 48 | (signals error (type-check :invalid-record-primitive-2)) 49 | ;; different error than 2 50 | (signals error (type-check :invalid-record-primitive)) 51 | (signals error (type-check :invalid-record-creation)) 52 | (signals error (type-check :invalid-application-unification)) 53 | (signals error (type-check :invalid-type-check)) 54 | (setf (v:repl-categories) old-categories)))) 55 | -------------------------------------------------------------------------------- /src/closure/closure.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.closure) 2 | 3 | ;; This is just a glorified hash table 4 | (defclass typ () 5 | ((table :initarg :table 6 | :type syc:tree-map 7 | :initform (syc:make-tree-map #'util:hash-compare) 8 | :accessor table)) 9 | (:documentation "The Closure type")) 10 | 11 | (defmethod print-object ((obj typ) stream) 12 | (print-unreadable-object (obj stream :type t) 13 | (format stream "~A" (table obj)))) 14 | 15 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | ;; Creation Functions 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | 19 | (defun allocate (&rest arguments) 20 | (from-plist arguments)) 21 | 22 | (-> from-plist (list) typ) 23 | (defun from-plist (plist) 24 | (values 25 | (make-instance 'typ 26 | :table (util:sycamore-plist-symbol-map plist)))) 27 | 28 | (-> from-alist (list) typ) 29 | (defun from-alist (alist) 30 | (values 31 | (make-instance 'typ 32 | :table (syc:alist-tree-map alist #'util:hash-compare)))) 33 | 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | ;; Addition Functions 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | (-> insert (typ keyword t) typ) 39 | (defun insert (closure name bound-value) 40 | (values 41 | (make-instance 'typ 42 | :table (syc:tree-map-insert (table closure) name bound-value)))) 43 | 44 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 45 | ;; Dumping Functions 46 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 | 48 | (-> keys (typ) list) 49 | (defun keys (closure) 50 | (sycamore:tree-map-keys (table closure))) 51 | 52 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | ;; Lookup Functions 54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 | 56 | (-> lookup (typ keyword) (or t null)) 57 | (defun lookup (closure name) 58 | (values 59 | (syc:tree-map-find (table closure) name))) 60 | 61 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 62 | ;; Removal Functions 63 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 64 | 65 | (-> remove (typ keyword) typ) 66 | (defun remove (closure name) 67 | (values 68 | (make-instance 'typ 69 | :table (syc:tree-map-remove (table closure) name)))) 70 | 71 | (-> length (typ) integer) 72 | (defun length (closure) 73 | (cl:length (sycamore:tree-map-keys (table closure)))) 74 | -------------------------------------------------------------------------------- /src/typechecker/size.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.typechecker.size) 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;; Determining the Size of the type 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | 6 | (-> reference (ir:type-reference) integer) 7 | (defun reference (typ) 8 | (values 9 | (etypecase-of ir:type-reference typ 10 | (ir:reference-type 11 | (let ((lookup (storage:lookup-type (ir:name typ)))) 12 | (if lookup 13 | (storage lookup) 14 | (error "type not found: ~A" (ir:name typ))))) 15 | (ir:application 16 | (or (primitive typ) 17 | (error "generics in user defined data type is not supported")))))) 18 | 19 | (-> storage (ir:type-storage) integer) 20 | (defun storage (storage) 21 | (values 22 | (etypecase-of ir:type-storage storage 23 | (ir:primitive (or (primitive storage) 24 | (error "type of primitive can not be resolved: ~A" 25 | storage))) 26 | (ir:type-declaration (declaration storage))))) 27 | 28 | (-> contents (ir:type-declaration) list) 29 | (defun contents (decl) 30 | (let ((format (ir:decl decl))) 31 | (etypecase-of ir:type-format format 32 | (ir:record-decl 33 | (mapcar (lambda (type-name) 34 | (~>> type-name 35 | (sycamore:tree-map-find (ir:contents format)) 36 | reference)) 37 | (ir:order format))) 38 | (ir:sum-decl 39 | (error "Sum types are not currently supported"))))) 40 | 41 | (-> declaration (ir:type-declaration) integer) 42 | (defun declaration (decl) 43 | (assure integer 44 | (sum (contents decl)))) 45 | 46 | (-> primitive ((or ir:primitive ir:application)) (or null integer)) 47 | (defun primitive (prim?) 48 | (flet ((handle-arguments (keyword-prim arguments) 49 | (typecase-of types:known-primitve-types keyword-prim 50 | ((eql :int) (if arguments (car arguments) 256)) 51 | ((eql :array) (* (reference (cadr arguments)) (car arguments))) 52 | ((eql :bool) 1) 53 | ((eql :void) 0) 54 | (otherwise nil)))) 55 | (etypecase-of (or ir:primitive ir:application) prim? 56 | (ir:primitive (handle-arguments (ir:name prim?) nil)) 57 | (ir:application (handle-arguments (ir:name (ir:func prim?)) 58 | (ir:arguments prim?)))))) 59 | 60 | -------------------------------------------------------------------------------- /test/packing.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (def-suite alucard.packing 4 | :description "Packing logic") 5 | 6 | (in-suite alucard.packing) 7 | 8 | (test array-packing-is-expected 9 | (let ((int32 (ir:to-type-reference-format '(int 32)))) 10 | (multiple-value-bind (context body) 11 | (check:with-intro (context bar baz) (make-instance 'check:typing-context) 12 | (pack:op 13 | context 14 | (check:make-type-info 15 | :type (ir:array-type :length 5 16 | :type int32) 17 | :size (* 32 5)) 18 | 35 19 | (ir:make-reference :name bar) 20 | (ir:make-reference :name baz) 21 | 37 22 | (ir:make-type-check :value 38 :typ int32))) 23 | (is (>= (length body) 6) 24 | "Since we go through ANF, and we do 5 *'s for the strategy should 25 | produce over 6 let bindings") 26 | (is (= (closure:length (check:typing-closure context)) 27 | (+ 2 (length body))) 28 | "Every value should be without a hole here, so it's all the lets +"))) 29 | 30 | (check:with-intro (context bar foo) (make-instance 'check:typing-context) 31 | (finishes 32 | (alu.pass.array::handle-term 33 | (alu.typechecker::solved 34 | bar 35 | (check:make-type-info 36 | :type (ir:array-type :length 5 37 | :type (ir:to-type-reference-format '(int 32))) 38 | :size (* 32 5)) 39 | context) 40 | (ir:make-bind :var bar 41 | :val (ir:make-from-data :contents (list (ir:make-reference :name foo) 42 | (ir:make-reference :name foo) 43 | (ir:make-reference :name foo) 44 | (ir:make-reference :name foo)))))))) 45 | 46 | ;; TODO Make a real test here. Namely for types and proper logic generaiton 47 | (test array-lookup-is-expected 48 | (finishes 49 | (check:with-intro (context bar) (make-instance 'check:typing-context) 50 | (pack:lookup-at 51 | context 52 | (check:make-type-info 53 | :type (ir:array-type :length 5 54 | :type (ir:to-type-reference-format '(int 32))) 55 | :size (* 32 5)) 56 | (ir:make-array-lookup 57 | :arr (ir:make-reference :name bar) 58 | :pos 3) 59 | 3 60 | (ir:make-reference :name bar))))) 61 | -------------------------------------------------------------------------------- /test/vampir.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (def-suite vampir 4 | :description "Test the vampir layer") 5 | 6 | (in-suite vampir) 7 | 8 | (defparameter *vamp-example-1* 9 | (list (vspc:make-pub :wires (list :fi :bar)) 10 | (vspc:make-alias 11 | :name :xor 12 | :inputs '(:a :b) 13 | :body (list (vspc:make-bind 14 | :names (list (vspc:make-wire :var :c)) 15 | :value (vspc:make-infix :op :+ 16 | :lhs (vspc:make-wire :var :a) 17 | :rhs (vspc:make-wire :var :b))) 18 | (vspc:make-wire :var :c))))) 19 | 20 | (defparameter *expected-1* 21 | (with-output-to-string (stream) 22 | (format stream "pub fi~%") 23 | (format stream "pub bar~%") 24 | (format stream "def xor a b {~%") 25 | (format stream " def c = a + b;~%") 26 | (format stream " c~%") 27 | (format stream "}"))) 28 | 29 | (defparameter *vamp-example-2* 30 | (list (vspc:make-pub :wires (list :fi :bar)) 31 | (vspc:make-alias 32 | :name :xor 33 | :inputs '(:a :b) 34 | :body 35 | (list (vspc:make-bind 36 | :names (list (vspc:make-wire :var :c)) 37 | :value #1=(vspc:make-infix :op :* 38 | :lhs (vspc:make-wire :var :a) 39 | :rhs (vspc:make-wire :var :b))) 40 | (vspc:make-equality 41 | :lhs (vspc:make-wire :var :baz) 42 | :rhs (vspc:make-infix :op :+ 43 | :lhs (vspc:make-wire :var :a) 44 | :rhs #1#)) 45 | (vspc:make-application 46 | :func :foo 47 | :arguments (list #1#)) 48 | (vspc:make-wire :var :c))))) 49 | 50 | (defparameter *expected-2* 51 | (with-output-to-string (stream) 52 | (format stream "pub fi~%") 53 | (format stream "pub bar~%") 54 | (format stream "def xor a b {~%") 55 | (format stream " def c = a * b;~%") 56 | (format stream " baz = a + (a * b);~%") 57 | (format stream " foo (a * b);~%") 58 | (format stream " c~%") 59 | (format stream "}"))) 60 | 61 | (test extract-alias 62 | (let ((ran-1 (with-output-to-string (stream) 63 | (vamp:extract *vamp-example-1* stream))) 64 | (ran-2 (with-output-to-string (stream) 65 | (vamp:extract *vamp-example-2* stream)))) 66 | (is (equalp *expected-1* ran-1)) 67 | (is (equalp *expected-2* ran-2)))) 68 | -------------------------------------------------------------------------------- /test/run-tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (defparameter *all-tests* 4 | (list 5 | 'alucard.format 6 | 'alucard.pass.anf 7 | 'alucard.expand 8 | 'alucard.relocation 9 | 'alucard.dependencies 10 | 'alucard.pass 11 | 'alucard.typecheck 12 | 'alucard.evaluate-body 13 | 'alucard.packing 14 | 'alucard.stack 15 | 'alucard.step 16 | 'vampir 17 | 'alucard)) 18 | 19 | (defun run-tests (&key (debug nil)) 20 | (let ((swapped (storage:currently-swapped?))) 21 | ;; I'm sorry I destroy your custom table if it isn't the test 22 | ;; one... this is a bug, please FIX ME 23 | (swap-tables) 24 | (if debug 25 | (mapc #'debug! *all-tests*) 26 | (mapc #'run! *all-tests*)) 27 | (unless swapped 28 | (storage:restore-tables)))) 29 | 30 | (defun profile-all () 31 | (let* ((packages 32 | (list-all-packages)) 33 | (alu-packages 34 | (remove-if-not (lambda (p) 35 | (let ((search (search "ALU" (package-name p)))) 36 | (and search (= 0 search)))) 37 | packages)) 38 | (without-aluser 39 | (remove-if (lambda (p) 40 | (member (package-name p) '("aluser" "alu-test") 41 | :test #'equalp)) 42 | alu-packages))) 43 | (mapc (lambda (alu) 44 | (slynk-backend:profile-package alu t t)) 45 | without-aluser))) 46 | 47 | (defun unprofile-all () 48 | (slynk-backend:unprofile-all)) 49 | 50 | (defun profiler-report () 51 | (slynk-backend:profile-report)) 52 | 53 | (defun profiler-reset () 54 | (slynk-backend:profile-reset)) 55 | 56 | #+ccl 57 | (defun code-coverage () 58 | (ccl:reset-incremental-coverage) 59 | (ccl:reset-coverage) 60 | 61 | (setq ccl:*compile-code-coverage* t) 62 | (asdf:compile-system :alu :force t) 63 | (asdf:compile-system :alu/test :force t) 64 | (swap-tables) 65 | 66 | (let ((coverage (make-hash-table))) 67 | ;; we want to note that some code loads before we can even test 68 | ;; it, so mark these under their own section 69 | (setf (gethash 'alucard.startup coverage) 70 | (ccl:get-incremental-coverage)) 71 | (mapc (lambda (test) 72 | (run! test) 73 | (setf (gethash test coverage) 74 | (ccl:get-incremental-coverage))) 75 | *all-tests*) 76 | (ccl:report-coverage #P"./html/report.html" :tags coverage)) 77 | 78 | (setq ccl:*compile-code-coverage* nil) 79 | (asdf:compile-system :alu :force t) 80 | (asdf:compile-system :alu/test :force t)) 81 | -------------------------------------------------------------------------------- /alu/prelude.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.prelude) 2 | 3 | (defprimitive-type int) 4 | (defprimitive-type int64) 5 | (defprimitive-type void) 6 | (defprimitive-type bool) 7 | (defprimitive-type array) 8 | 9 | (defprimitive void) 10 | (defprimitive +) 11 | (defprimitive *) 12 | (defprimitive =) 13 | (defprimitive range) 14 | (defprimitive exp) 15 | 16 | (defmacro deflex (var &body (&optional val documentation)) 17 | ;; documentation copied from def in serpaeum 18 | "The famous \"deflex\". 19 | 20 | Define a top level (global) lexical VAR with initial value VAL, 21 | which is assigned unconditionally as with DEFPARAMETER. If a DOC 22 | string is provided, it is attached to both the name |VAR| and the name 23 | *STORAGE-FOR-DEFLEX-VAR-|VAR|* as a documentation string of kind 24 | 'VARIABLE. The new VAR will have lexical scope and thus may be 25 | shadowed by LET bindings without affecting its dynamic (global) value. 26 | 27 | The original `deflex' is due to Rob Warnock. 28 | 29 | This version of `deflex' differs from the original in the following ways: 30 | 31 | - It is possible for VAL to close over VAR. 32 | - On implementations that support it (SBCL, CCL, and LispWorks, at the 33 | moment) this version creates a backing variable that is \"global\" or 34 | \"static\", so there is not just a change in semantics, but also a 35 | gain in efficiency. 36 | - If VAR is a list that starts with `values`, each element is treated as 37 | a separate variable and initialized as if by `(setf (values VAR...) 38 | VAL)`." 39 | `(serapeum:def ,var ,val ,documentation)) 40 | 41 | (defmacro vampir (function-name) 42 | `(vampir-keyword ,(util:symbol-to-keyword function-name))) 43 | 44 | (defun vampir-keyword (keyword) 45 | (let ((lookup (storage:lookup-function keyword))) 46 | (if lookup 47 | (pipeline:pipeline lookup) 48 | (format t "Function ~A is not found" keyword)))) 49 | 50 | (defun start-slynk (&key (port 4005)) 51 | ;; doesn't work in CCL for some reason... 52 | (slynk-api:add-hook slynk-api:*new-connection-hook* 53 | (lambda (connection) 54 | (declare (ignore connection)) 55 | (slynk:set-package :aluser) 56 | (setf *print-pretty* t))) 57 | (slynk:create-server :port port :dont-close t)) 58 | 59 | (defun start-swank (&key (port 4005)) 60 | ;; this maybe works? 61 | (swank::add-hook swank::*new-connection-hook* 62 | (lambda (connection) 63 | (declare (ignore connection)) 64 | (slynk:set-package :aluser) 65 | (setf *print-pretty* t))) 66 | (swank:create-server :port port :dont-close t)) 67 | -------------------------------------------------------------------------------- /src/util/bit.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.utils) 2 | 3 | (defconstant +byte-size+ 8) 4 | 5 | (-> string-to-number (string) integer) 6 | (defun string-to-number (string) 7 | "converts a string to a numerical encoding" 8 | ;; if we had map-accum-r, we could do this with an accumulator 9 | (assure integer 10 | (let ((cont 0)) 11 | (sum (map 'list 12 | (lambda (c) 13 | (prog1 14 | (ash (char-code c) (* cont +byte-size+)) 15 | (incf cont (char-byte-size c)))) 16 | ;; we should probably remove this and encode it with the 17 | ;; first element in the last position of the bitstring. 18 | (reverse string)))))) 19 | 20 | (-> sequence-to-number (fixnum sequence) integer) 21 | (defun sequence-to-number (size arr) 22 | "converts a sequence literal to a numerical encoding" 23 | (assure integer 24 | (sum (map 'list 25 | (lambda (ele count) (ash ele (* count size))) 26 | arr 27 | (alexandria:iota (length arr)))))) 28 | 29 | ;; I can speed this up by manually setfing the fill pointer instead, 30 | ;; or tracking it, but makes the code less clear 31 | (-> string-to-bit-array (string) bit-vector) 32 | (defun string-to-bit-array (string) 33 | "converts a string to a bit-vector encoding. Should agree with `string-to-number'" 34 | (let* ((size (string-bit-size string)) 35 | (bit-array (make-array size :element-type 'bit :fill-pointer 0))) 36 | (map nil (lambda (c) (char-to-bit-array c bit-array)) string) 37 | bit-array)) 38 | 39 | (-> char-to-bit-array (character &optional bit-vector) bit-vector) 40 | (defun char-to-bit-array (char &optional 41 | (bit-array (make-array (char-code char) 42 | :element-type 'bit 43 | :fill-pointer 0))) 44 | (let ((numb (char-code char)) 45 | (size (char-bit-size char))) 46 | (dotimes (i (char-bit-size char) bit-array) 47 | (vector-push (if (logbitp (- size i 1) numb) 1 0) bit-array)))) 48 | 49 | (-> string-bit-size (string) fixnum) 50 | (defun string-bit-size (string) 51 | (* (string-byte-size string) +byte-size+)) 52 | 53 | (-> char-bit-size (character) fixnum) 54 | (defun char-bit-size (char) 55 | (* (char-byte-size char) +byte-size+)) 56 | 57 | (-> string-byte-size (string) fixnum) 58 | (defun string-byte-size (string) 59 | (values 60 | (sum (map 'list #'char-byte-size string)))) 61 | 62 | (-> char-byte-size (character) fixnum) 63 | (defun char-byte-size (char) 64 | "Calculates how many bytes is needed to model the current char" 65 | (ceiling (integer-length (char-code char)) 66 | +byte-size+)) 67 | -------------------------------------------------------------------------------- /src/spec/type.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.spec) 2 | 3 | (deftype type-reference () 4 | "When we refer to the type in the language it will be through the type 5 | reference. If we are apply a type, then " 6 | `(or reference-type 7 | ;; can be found in alu/term.lisp 8 | application)) 9 | 10 | ;; dispatch-case has issue with sub checking so we inline type-reference below 11 | (deftype type-reference-full () 12 | "This handles the case of references to types and what they may be 13 | applied upon" 14 | `(or reference-type application number)) 15 | 16 | (defclass reference-type () 17 | ((name :initarg :name 18 | :type keyword 19 | :accessor name 20 | :documentation "Type reference")) 21 | (:documentation "Represents a variable in the Alucard language")) 22 | 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | ;; Array Functioanlity 25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 | 27 | (-> array-type (&key (:length fixnum) (:type type-reference)) application) 28 | (defun array-type (&key length type) 29 | (values 30 | (make-application :function (make-type-reference :name :array) 31 | :arguments (list length type)))) 32 | 33 | 34 | (-> array-type-len (application) fixnum) 35 | (defun array-type-len (arr) 36 | (car (arguments arr))) 37 | 38 | (-> array-type-content (application) type-reference) 39 | (defun array-type-content (arr) 40 | (cadr (arguments arr))) 41 | 42 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 | ;; Extra Functionality On Types ;; 44 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 45 | 46 | (defun to-type-reference-format (term) 47 | "Given an application or a symbol, transform it to the correct type 48 | storage format. So for example 49 | 50 | 1. int -> (make-type-reference :name :int) 51 | 2. (int 64) -> (make-application :name (make-type-reference :name :int) 52 | :arguments (list 64))" 53 | ;; can either be a list number or atom 54 | (cond ((listp term) 55 | (let ((type-ref (mapcar #'to-type-reference-format term))) 56 | (make-application :function (car type-ref) :arguments (cdr type-ref)))) 57 | ((numberp term) 58 | term) 59 | (t 60 | (make-type-reference :name (alu.utils:symbol-to-keyword term))))) 61 | 62 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 63 | ;; Type Declaration Functions ;; 64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 | 66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 | ;; Reference Functionality 68 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 69 | 70 | (defmethod print-object ((obj reference-type) stream) 71 | (print-unreadable-object (obj stream :type t) 72 | (format stream "~A" (name obj)))) 73 | 74 | (defun make-type-reference (&key name) 75 | (make-instance 'reference-type :name name)) 76 | -------------------------------------------------------------------------------- /app/main.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu) 2 | 3 | ;; We can generate out our image with 4 | ;; (asdf:make :alu) 5 | 6 | (defparameter +command-line-spec+ 7 | '((("input" #\i) 8 | :type string :optional t :documentation "Input alucard file location") 9 | (("output" #\o) 10 | :type string :optional t :documentation "Sets compiler to compile mode and output vampir file location") 11 | (("help" #\h #\?) 12 | :type boolean :optional t :documentation "The current help message") 13 | (("swank" #\s) 14 | :type boolean :optional t :documentation "Launches a swank server for text editor integration") 15 | (("alive" #\a) 16 | :type boolean :optional t :documentation "Launches an alive server for text editor integration") 17 | (("sly" #\y) 18 | :type boolean :optional t :documentation "Launches a sly server for emacs integration") 19 | (("port" #\p) 20 | :type integer :optional t :documentation "The port for the swank/sly server. Defaults to 4005 ") 21 | ;; (("check" #\c) 22 | ;; :type string :optional t :documentation "a --check or -c flag that takes a string") 23 | ;; (("warn" "warning" #\w) 24 | ;; :type boolean :optional t :documentation "multiple spellings possible") 25 | ;; (("version" #\V) 26 | ;; :type boolean :optional t :documentation "--version or -V, you get the idea") 27 | )) 28 | 29 | (defun main () 30 | (setf uiop:*command-line-arguments* (uiop:command-line-arguments)) 31 | (command-line-arguments:handle-command-line 32 | +command-line-spec+ 33 | #'argument-handlers 34 | :name "alucard")) 35 | 36 | (defun argument-handlers (&key help output input sly swank port alive) 37 | (flet ((startup-function () 38 | (let ((port (or port 4005))) 39 | (when swank 40 | (aluser:start-swank :port port)) 41 | (when sly 42 | (aluser:start-slynk :port port)) 43 | (when alive 44 | ;; really janky please fix 45 | (ql:quickload :alive-lsp) 46 | (uiop:symbol-call :alive/server :start))) 47 | (when input 48 | (load input)))) 49 | (cond (help 50 | (command-line-arguments:show-option-help +command-line-spec+ :sort-names t)) 51 | ((and output input) 52 | (load input) 53 | (alu.pipeline:dump-entry-point-to-file output)) 54 | (output 55 | (format t "Need an input file in order to generate an output file~%")) 56 | (t 57 | (start-repl #'startup-function))))) 58 | 59 | (defun start-repl (&optional (func (lambda () 1))) 60 | (funcall func) 61 | #+ccl 62 | (ccl:toplevel-loop) 63 | #+sbcl 64 | (sb-impl::toplevel-init) 65 | #+ecl 66 | (si:top-level t)) 67 | 68 | ;; If you want compression on your asdf 69 | ;; Though I overload so this isn't needed anymore 70 | (defun save-alu-and-die () 71 | #+ccl 72 | (ccl:save-application "image" :prepend-kernel t 73 | :toplevel-function #'main) 74 | #+sbcl 75 | (sb-ext:save-lisp-and-die #p"./build/alu.image" 76 | :toplevel #'main 77 | :executable t 78 | :COMPRESSION 1)) 79 | -------------------------------------------------------------------------------- /src/spec/storage.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.storage) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Language Storage Locations 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | ;; *type-table* : Hash-Table keyword type-storage 8 | (defvar *types* (make-hash-table :test #'eq) 9 | "Serves as the table which stores all the circuit types that are 10 | relevant to the system") 11 | 12 | ;; *function-table* : Hash-Table keyword function-type 13 | (defvar *functions* (make-hash-table :test #'eq) 14 | "Serves as the table which stores all custom circuits that are 15 | defined") 16 | 17 | (defvar *entry-point* nil 18 | "Serves as the entry point to the generated circuit") 19 | 20 | (defvar *cannonical-function-table* nil 21 | "serves as the backup of the original function table. Useful when 22 | swapping to another env") 23 | 24 | (defvar *cannonical-type-table* nil 25 | "serves as the backup of the original type table. Useful when 26 | swapping to another env") 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;; Entry Functions 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | 32 | (defun get-entry-point () 33 | "Grabs the entry point function for the alucard program" 34 | *entry-point*) 35 | 36 | (defun set-entry-point (keyword) 37 | (setf *entry-point* keyword)) 38 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 39 | ;; Storage Addition Functions 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | 42 | (-> add-function (keyword format:function-type) t) 43 | (defun add-function (name func) 44 | "Adds the given function to the `*functions' table" 45 | (setf (gethash name *functions*) func)) 46 | 47 | (-> add-type (keyword format:type-storage) t) 48 | (defun add-type (name type) 49 | "Adds the given Type to the `*types*' table" 50 | (setf (gethash name *types*) type)) 51 | 52 | (-> lookup-function (keyword) (or format:function-type null)) 53 | (defun lookup-function (name) 54 | (gethash name *functions*)) 55 | 56 | (-> lookup-type (keyword) (or format:type-storage null)) 57 | (defun lookup-type (name) 58 | (gethash name *types*)) 59 | 60 | (-> swap-tables (hash-table hash-table) null) 61 | (defun swap-tables (func-table type-table) 62 | (when (and (not *cannonical-function-table*) 63 | (not *cannonical-type-table*)) 64 | (setf *cannonical-function-table* *functions* 65 | *cannonical-type-table* *types*)) 66 | 67 | (setf *functions* func-table 68 | *types* type-table) 69 | nil) 70 | 71 | (-> restore-tables () null) 72 | (defun restore-tables () 73 | (if (or (not *cannonical-function-table*) 74 | (not *cannonical-type-table*)) 75 | (error "Must swap the tables to restore the original tables!") 76 | (progn 77 | (setf *functions* *cannonical-function-table* 78 | *types* *cannonical-type-table*) 79 | (setf *cannonical-function-table* nil 80 | *cannonical-type-table* nil) 81 | nil))) 82 | 83 | (-> currently-swapped? () boolean) 84 | (defun currently-swapped? () 85 | (and (hash-table-p *cannonical-function-table*) 86 | (hash-table-p *cannonical-function-table*))) 87 | -------------------------------------------------------------------------------- /src/spec/data-traversal.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.spec) 2 | 3 | (defclass direct-slots-mixin () () 4 | (:documentation 5 | "Provides the service of giving generic access to all direct fields in 6 | the class. This allows generic programming to be had ")) 7 | 8 | ;; Issue is that we have to include protected by hand on all classes 9 | ;; that I want to use this ☹ 10 | (defclass protect-slots-mixin (direct-slots-mixin) 11 | ((protected :initform (make-hash-table :test #'eq) 12 | :allocation :class 13 | :accessor protected)) 14 | (:documentation 15 | "Extends the service of `direct-slot-mixin' by allowing the filtering 16 | of fields that the programmer does not want to be treated 17 | generically. Further, class allocated slots are ignored.")) 18 | 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | ;; Interface Functions 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | 23 | (defgeneric direct-slot-names (obj) 24 | (:documentation "Grabs all the direct slots of the class.")) 25 | 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | ;; Protect slots custom functions 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | 30 | (-> protect-slots (symbol &rest symbol) (or t null)) 31 | (defun protect-slots (class-name &rest protected-symbols) 32 | "Add the following protected symbols to the class's direct-slot list" 33 | (let ((class (find-class class-name))) 34 | (unless (c2mop:class-finalized-p class) 35 | (c2mop:finalize-inheritance class)) 36 | 37 | (let ((table (slot-value (c2mop:class-prototype class) 'protected))) 38 | (mapc (lambda (symbol) 39 | (setf (gethash symbol table) t)) 40 | protected-symbols)))) 41 | 42 | (defmethod direct-slot-names ((obj protect-slots-mixin)) 43 | (filter-map (lambda (x) 44 | (let ((name (c2mop:slot-definition-name x))) 45 | (if (or (eq (c2mop:slot-definition-allocation x) :class) 46 | (gethash name (protected obj))) 47 | nil 48 | (c2mop:slot-definition-name x)))) 49 | (c2mop:class-direct-slots (class-of obj)))) 50 | 51 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | ;; Direct slots custom functions 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | 55 | (defmethod direct-slot-names ((obj direct-slots-mixin)) 56 | (mapcar #'c2mop:slot-definition-name 57 | (c2mop:class-direct-slots (class-of obj)))) 58 | 59 | (defmethod direct-slot-keywords ((obj direct-slots-mixin)) 60 | "Grabs all the direct slots of the class, interned to being keywords" 61 | (mapcar #'util:symbol-to-keyword (direct-slot-names obj))) 62 | 63 | (defmethod direct-slots ((obj direct-slots-mixin)) 64 | "Grabs all the direct slots of the class and gives back a plist" 65 | (mapcar (lambda (x) 66 | (cons (util:symbol-to-keyword x) 67 | (slot-value obj x))) 68 | (direct-slot-names obj))) 69 | 70 | (defmethod direct-slot-values ((obj direct-slots-mixin)) 71 | "Grabs the data from the class" 72 | (mapcar (lambda (x) (slot-value obj x)) 73 | (direct-slot-names obj))) 74 | 75 | (defun update-from-alist (obj alist) 76 | (apply #'util:copy-instance obj (alexandria:alist-plist alist))) 77 | -------------------------------------------------------------------------------- /src/pass/redundant-let.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.pass.redundant) 2 | 3 | (-> find-redundant-let (ir:fully-expanded-list &optional closure:typ) closure:typ) 4 | (defun find-redundant-lets (xs &optional (map (closure:allocate))) 5 | (mvfold (lambda (map x) 6 | (etypecase-of ir:fully-expanded-term x 7 | ((or ir:standalone-ret ir:multiple-bind) 8 | map) 9 | (ir:bind 10 | (etypecase-of ir:base (ir:value x) 11 | (ir:application map) 12 | (number (closure:insert map (ir:var x) (ir:value x))) 13 | (ir:reference (let* ((value (ir:value x)) 14 | (find (closure:lookup map (ir:name value)))) 15 | (closure:insert map (ir:var x) (or find value)))))) 16 | (ir:bind-constraint 17 | (find-redundant-lets (ir:value x) map)))) 18 | xs map)) 19 | 20 | (-> replace-references (ir:fully-expanded-list closure:typ) ir:fully-expanded-list) 21 | (defun replace-references (xs map) 22 | (mapcar 23 | (lambda (x) 24 | (etypecase-of ir:fully-expanded-term x 25 | (ir:multiple-bind x) 26 | (ir:bind-constraint (util:copy-instance 27 | x :value (replace-references (ir:value x) map))) 28 | (ir:standalone-ret 29 | (let* ((vars (ir:var x)) 30 | (updated-rets 31 | (mapcar (lambda (y) 32 | (let ((find (closure:lookup map y))) 33 | (if find 34 | (etypecase-of ir:term-normal-form (closure:lookup map y) 35 | (ir:reference (ir:name (closure:lookup map y))) 36 | (number (closure:lookup map y))) 37 | y))) 38 | vars))) 39 | (ir:make-standalone-ret :var updated-rets))) 40 | (ir:bind 41 | (etypecase-of ir:base (ir:value x) 42 | (ir:reference x) 43 | (number x) 44 | (ir:application 45 | (let* ((value (ir:value x)) 46 | (updated-refs 47 | (mapcar (lambda (y) 48 | (etypecase-of ir:base y 49 | (number y) 50 | (ir:application y) 51 | (ir:reference (or (closure:lookup map (ir:name y)) 52 | y)))) 53 | (ir:arguments value)))) 54 | (util:copy-instance 55 | x :value (util:copy-instance value 56 | :arguments updated-refs)))))))) 57 | xs)) 58 | 59 | 60 | (-> remove-redundant-lets (ir:fully-expanded-list closure:typ) ir:fully-expanded-list) 61 | (defun remove-redundant-lets (xs map) 62 | (filter-map (lambda (x) 63 | (etypecase-of ir:fully-expanded-term x 64 | ((or ir:standalone-ret ir:multiple-bind) 65 | x) 66 | (ir:bind 67 | (if (closure:lookup map (ir:var x)) nil x)) 68 | (ir:bind-constraint 69 | (util:copy-instance 70 | x :value (remove-redundant-lets (ir:value x) map))))) 71 | xs)) 72 | -------------------------------------------------------------------------------- /src/intermediate/new-terms.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.ir.new-terms) 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;; New Terms 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | 6 | (defclass bind (spc:meta-mixin) 7 | ((var :initarg :variable 8 | :type keyword 9 | :accessor spc:var 10 | :documentation "The variable that will be bound") 11 | (value :initarg :value 12 | :accessor spc:value 13 | :type spc:term-type-manipulation 14 | :documentation "the value that is bound")) 15 | (:documentation "A let with a more restrictive value type")) 16 | 17 | (defclass multiple-bind (spc:meta-mixin) 18 | ((variables :initarg :variables 19 | :type list 20 | :accessor spc:var 21 | :documentation "The variables of type `keyword' that will be bound") 22 | (value :initarg :value 23 | :accessor spc:value 24 | :type spc:term-type-manipulation 25 | :documentation "the value that is bound")) 26 | (:documentation "A let that can bind many return values")) 27 | 28 | (defclass standalone-ret (spc:meta-mixin) 29 | ((variable :initarg :variable 30 | :type list 31 | :accessor spc:var 32 | :documentation "The name that will be returned")) 33 | (:documentation "Values which will be returned")) 34 | 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | ;; Constructors 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | ;; Bind Functionality 41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 | 43 | (defmethod print-object ((obj bind) stream) 44 | (print-unreadable-object (obj stream) 45 | (with-accessors ((value spc:value) (var spc:var)) obj 46 | (format stream "LET ~A = ~A" var value)))) 47 | 48 | (-> make-bind (&key (:var keyword) (:val spc:term-type-manipulation)) bind) 49 | (defun make-bind (&key (var (error "Please provide the variable")) 50 | (val (error "Please provide the value field"))) 51 | (values 52 | (make-instance 'bind :value val :variable var))) 53 | 54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 | ;; Multiple Bind Functionality 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | 58 | (defmethod print-object ((obj multiple-bind) stream) 59 | (print-unreadable-object (obj stream) 60 | (with-accessors ((value spc:value) (var spc:var)) obj 61 | (format stream "MULTI-LET ~A = ~A" var value)))) 62 | 63 | (-> make-multiple-bind 64 | (&key (:var list) (:val spc:term-no-binding)) multiple-bind) 65 | (defun make-multiple-bind (&key (var (error "Please provide the variable")) 66 | (val (error "Please provide the value field"))) 67 | (values 68 | (make-instance 'multiple-bind :value val :variables var))) 69 | 70 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 71 | ;; Return Functionality 72 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 73 | (defmethod print-object ((obj standalone-ret) stream) 74 | (print-unreadable-object (obj stream :type t) 75 | (format stream "~{~A~^, ~}" (spc:var obj)))) 76 | 77 | 78 | (defun make-standalone-ret (&key (var (error "Please provide the return name"))) 79 | (values 80 | (make-instance 'standalone-ret :variable var))) 81 | -------------------------------------------------------------------------------- /src/util/utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.utils) 2 | 3 | (defun symbol-to-keyword (symbol) 4 | (intern (symbol-name symbol) :keyword)) 5 | 6 | (defun hash-compare (x y) 7 | "hash compare compare twos symbols" 8 | (let ((hash-x (sxhash x)) 9 | (hash-y (sxhash y))) 10 | (cond ((< hash-x hash-y) -1) 11 | ((> hash-x hash-y) 1) 12 | (t 0)))) 13 | 14 | (defun sycamore-plist-symbol-map (plist) 15 | (sycamore:alist-tree-map (alexandria:plist-alist plist) #'hash-compare)) 16 | 17 | (defun sycamore-symbol-map-plist (tree-map) 18 | (alexandria:alist-plist (sycamore:tree-map-alist tree-map))) 19 | 20 | ;; from 21 | ;; https://stackoverflow.com/questions/11067899/is-there-a-generic-method-for-cloning-clos-objects 22 | 23 | ;; Don't need it to be an object on non standard-classes for this 24 | ;; project, if so, we can promote it to the old form of being a 25 | ;; defgeneric. 26 | 27 | (-> copy-instance (standard-object &rest t &key &allow-other-keys) standard-object) 28 | (defun copy-instance (object &rest initargs &key &allow-other-keys) 29 | "Makes and returns a shallow copy of OBJECT. 30 | 31 | An uninitialized object of the same class as OBJECT is allocated by 32 | calling ALLOCATE-INSTANCE. For all slots returned by 33 | CLASS-SLOTS, the returned object has the 34 | same slot values and slot-unbound status as OBJECT. 35 | 36 | REINITIALIZE-INSTANCE is called to update the copy with INITARGS." 37 | (let* ((class (class-of object)) 38 | (copy (allocate-instance class))) 39 | (dolist (slot (c2mop:class-slots class)) 40 | ;; moved the mapcar into a let, as allocation wise, CCL 41 | ;; preformed better this way. 42 | (let ((slot-name (c2mop:slot-definition-name slot))) 43 | (when (slot-boundp object slot-name) 44 | (setf (slot-value copy slot-name) 45 | (slot-value object slot-name))))) 46 | (values 47 | (apply #'reinitialize-instance copy initargs)))) 48 | 49 | ;; I should use this for object equality, namely the slot values trick 50 | 51 | ;; Please abstract out this logic. Too much of the same pattern!!! 52 | 53 | (defun alist-values (alist) 54 | "Takes a potentially nested alist and returns the values 55 | 56 | (alist-values '((:plane . :fi-plane) (:point . ((:x . fi-point-x) (:y . fi-point-y))))) 57 | 58 | ==> 59 | 60 | (:FI-PLANE FI-POINT-X FI-POINT-Y)" 61 | (mapcan (lambda (apair) 62 | (if (not (listp (cdr apair))) 63 | (list (cdr apair)) 64 | (alist-values (cdr apair)))) 65 | alist)) 66 | 67 | (defun nested-alist-keys (alist) 68 | "Takes a potentially nested alist and returns all the keys 69 | 70 | (nested-alist-keys '((:plane . :fi-plane) (:point . ((:x . fi-point-x) (:y . fi-point-y))))) 71 | 72 | ==> 73 | 74 | (:PLANE :POINT :X :Y)" 75 | (mapcan (lambda (apair) 76 | (if (not (listp (cdr apair))) 77 | (list (car apair)) 78 | (cons (car apair) (nested-alist-keys (cdr apair))))) 79 | alist)) 80 | 81 | (defun leaf-alist-keys (alist) 82 | "Takes a nested alist and gives back all the keys on the leaves 83 | 84 | (leaf-alist-keys '((:plane . :fi-plane) (:point . ((:x . fi-point-x) (:y . fi-point-y))))) 85 | 86 | ==> 87 | 88 | (:PLANE :X :Y)" 89 | (mapcan (lambda (apair) 90 | (if (not (listp (cdr apair))) 91 | (list (car apair)) 92 | (leaf-alist-keys (cdr apair)))) 93 | alist)) 94 | -------------------------------------------------------------------------------- /src/pass/array.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.pass.array) 2 | 3 | (-> handle-terms 4 | (check:typing-context ir:expanded-list) 5 | (values check:typing-context ir:expanded-list)) 6 | (defun handle-terms (context terms) 7 | (mvfoldr (lambda (term context terms) 8 | (multiple-value-bind (context new-terms) (handle-term context term) 9 | (values context 10 | (append new-terms terms)))) 11 | terms 12 | context 13 | nil)) 14 | 15 | (-> handle-term (check:typing-context ir:expanded-term) 16 | (values check:typing-context ir:expanded-list)) 17 | (defun handle-term (context term) 18 | (flet ((do-nothing () 19 | (values context (list term))) 20 | (rebind-term (term-list updated-binding) 21 | (append term-list 22 | (list (util:copy-instance term :value updated-binding))))) 23 | (etypecase-of ir:expanded-term term 24 | (ir:standalone-ret (do-nothing)) 25 | (ir:bind 26 | (etypecase-of ir:term-no-binding (ir:value term) 27 | (ir:base (do-nothing)) 28 | (ir:record-forms (do-nothing)) 29 | ;; TODO Fix Array Set 30 | (ir:array-set (do-nothing)) 31 | (ir:array-lookup 32 | (multiple-value-bind (context ts) (lookup context (ir:value term)) 33 | (values context 34 | (rebind-term ts 35 | (pack:array-lookup-final-ref ts))))) 36 | (ir:array-allocate 37 | (values context 38 | (util:copy-instance term :var (allocate (ir:value term))))) 39 | (ir:from-data 40 | (multiple-value-bind (context ts) (to-array context term) 41 | (values context 42 | (rebind-term ts 43 | (pack:final-ref-from-op ts))))))) 44 | (ir:bind-constraint 45 | (multiple-value-bind (context expanded) (handle-terms context 46 | (ir:value term)) 47 | (values context 48 | (list 49 | (util:copy-instance term 50 | :value expanded)))))))) 51 | 52 | (-> to-array 53 | (check:typing-context ir:bind) 54 | (values check:typing-context ir:expanded-list)) 55 | (defun to-array (context term) 56 | (let* ((type (check:typing-closure context)) 57 | (value (closure:lookup type (ir:var term)))) 58 | (assert (typep (ir:value term) 'ir:from-data)) 59 | (if value 60 | (apply #'pack:op context value (ir:value term) (ir:contents (ir:value term))) 61 | (error "Value ~A not found in the typing map ~A" value term)))) 62 | 63 | (-> lookup 64 | (check:typing-context ir:array-lookup) 65 | (values check:typing-context ir:expanded-list)) 66 | (defun lookup (context term) 67 | (let* ((type (check:typing-closure context)) 68 | (value (closure:lookup type (ir:name (ir:arr term))))) 69 | (if value 70 | (pack:lookup-at context value term (ir:pos term) (ir:arr term)) 71 | (error "Value ~A not found in the typing map" value)))) 72 | 73 | (-> allocate (ir:array-allocate) ir:term-normal-form) 74 | (defun allocate (term) 75 | (declare (ignore term)) 76 | 0) 77 | 78 | (-> arr-set 79 | (check:typing-context ir:array-set) 80 | (values check:typing-context ir:expanded-list)) 81 | (defun arr-set (context set) 82 | context set 83 | (error "not implemented")) 84 | -------------------------------------------------------------------------------- /test/stack.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (def-suite alucard.stack 4 | :description "Testing stack semantics") 5 | 6 | (in-suite alucard.stack) 7 | 8 | ;; I could be much more thorough in testing this, but it would just 9 | ;; involve me mimicking calls tediously. 10 | 11 | (test dynamic-variable-respected 12 | (let ((current-stack (stack:get))) 13 | (stack:with-empty-stack () 14 | (stack:push 3) 15 | (stack:push 10) 16 | (stack:push 20) 17 | (is (equalp 18 | (list 20 10 3) 19 | (stack:stack (stack:get))) 20 | "We should be pushing on a fresh stack")) 21 | (is (equalp (stack:get) 22 | current-stack) 23 | "Our operations should not have pushed globally"))) 24 | 25 | (test function-section 26 | (stack:with-section faz 27 | (stack:push '(+ 1 2 3)) 28 | (stack:push '(+ b c d)) 29 | (stack:push '(+ e f g)) 30 | (is (equalp 31 | (stack:stack (stack:current-section (stack:get))) 32 | '((+ e f g) 33 | (+ b c d) 34 | (+ 1 2 3)))))) 35 | 36 | ;; I'm being lazy I shouldn't check the printed version, but rather 37 | ;; make equality or a quick way to check equality of my objects 38 | 39 | (defparameter *inner-output* 40 | "((:IN BAZ 41 | (/ C D) 42 | (* A B (/ C D))) 43 | (:IN FAZ 44 | (/ C D) 45 | (* A B (/ C D))))") 46 | 47 | (defparameter *outer-output* 48 | "((:IN FAZ 49 | (/ C D) 50 | (* A B (/ C D))))") 51 | 52 | (defparameter *outer-cdr* 53 | "((:IN FAZ 54 | (* A B (/ C D))))") 55 | 56 | 57 | ;; Being lazy about testing and using streams. 58 | (test removing-works-as-expected 59 | (let ((*print-pretty* t) 60 | (output-stream-baz (make-string-output-stream)) 61 | (output-stream-faz (make-string-output-stream)) 62 | (output-stream-manual (make-string-output-stream)) 63 | (output-stream-manual-cdr (make-string-output-stream))) 64 | (stack:with-empty-stack () 65 | (stack:with-section faz 66 | (stack:push '(* a b (/ c d))) 67 | (stack:push '(/ c d)) 68 | (stack:with-section baz 69 | (stack:push '(* a b (/ c d))) 70 | (stack:push '(/ c d)) 71 | ;; dump the current stack to the output stream 72 | (print-object (stack:get) output-stream-baz) 73 | ;; we cdr 3 times to pop the baz out of it!, thus we should 74 | ;; be the same as faz. and the printing should also work 75 | ;; exactly the same. 76 | (let ((remove-baz-by-hand 77 | (stack:cdr (stack:cdr 78 | (stack:cdr (stack:get)))))) 79 | (print-object remove-baz-by-hand output-stream-manual) 80 | ;; this should cdr off an element off faz 81 | (print-object (stack:cdr remove-baz-by-hand) 82 | output-stream-manual-cdr))) 83 | ;; weird how the formatting changes between calls 84 | (print-object (stack:get) output-stream-faz) 85 | (let ((output-faz (get-output-stream-string output-stream-faz))) 86 | (is (string= *inner-output* 87 | (get-output-stream-string output-stream-baz)) 88 | "Scope should be respected and we should be double 89 | nested") 90 | (is (string= output-faz 91 | *outer-output*) 92 | "formatting for this should be precise and nice, with 93 | the outer section gone outside of the scope") 94 | (is (string= (get-output-stream-string output-stream-manual) 95 | output-faz) 96 | "Removing the two elements in baz plus the baz function 97 | marker should be the same as leaving the section") 98 | (is (string= (get-output-stream-string output-stream-manual-cdr) 99 | *outer-cdr*) 100 | "Cdring a nil section should lead to cdring the next 101 | section on the stack")))))) 102 | -------------------------------------------------------------------------------- /src/pass/pipeline.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.pipeline) 2 | 3 | ;; TODO :: Make a Berlin pipeline abstraction, we really need to stop 4 | ;; half way through for easier testing! until then I'll just have many 5 | ;; arrow functions for where I want to stop off! 6 | 7 | (-> to-typecheck (ir:circuit) (values ir:expanded-list check:typing-context)) 8 | (-> to-expand-away-arrays (ir:circuit) (values ir:expanded-list check:typing-context)) 9 | (-> to-expand-away-records (ir:circuit) ir:fully-expanded-list) 10 | (-> to-primitive-circuit (ir:circuit) ir:prim-circuit) 11 | (-> to-vampir (ir:circuit) alu.vampir.spec:alias) 12 | 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | ;; Compile Circuit and Dependencies 15 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | 17 | (defun dump-entry-point (&optional (stream *standard-output*)) 18 | (print-vampir (comp-all (storage:lookup-function (storage:get-entry-point))) 19 | stream)) 20 | 21 | (defun dump-entry-point-to-file (file-name) 22 | (with-open-file (file file-name :direction :output 23 | :if-exists :overwrite 24 | :if-does-not-exist :create) 25 | (dump-entry-point file))) 26 | 27 | (defun comp-all (circuit) 28 | (mapcar #'pipeline 29 | (cons circuit 30 | (filter-map (alexandria:compose (lambda (circ) 31 | (and (typep circ 'ir:circuit) 32 | circ)) 33 | #'storage:lookup-function) 34 | (dep:track-circuit-deps* circuit))))) 35 | 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | ;; Pipeline Proper 38 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 39 | 40 | (defun print-vampir (vampir &optional (stream *standard-output*)) 41 | (vampir:extract vampir stream)) 42 | 43 | (-> pipeline (ir:circuit) (or t alu.vampir.spec:alias)) 44 | (defun pipeline (circuit) 45 | (handler-case (~> circuit 46 | to-vampir) 47 | (log:error (c) 48 | (format t "~%;;;;;;;;;;;;;;;;;;;;;;~%In Function ~A~%;;;;;;;;;;;;;;;;;;;;;;" 49 | (ir:name circuit)) 50 | (log:data c)) 51 | (simple-error (c) 52 | (format t "~A" c)))) 53 | 54 | (defun to-typecheck (circuit) 55 | (mvlet ((body typing (~> circuit 56 | pass:linearize 57 | (check:check circuit)))) 58 | (values 59 | (pass:remove-type-information body) 60 | typing))) 61 | 62 | (defun to-expand-arrays (circuit) 63 | (mvlet* ((body context (to-typecheck circuit)) 64 | (context body (~>> body 65 | (array:handle-terms context)))) 66 | (values 67 | body 68 | context))) 69 | 70 | (defun to-expand-away-records (circuit) 71 | (~> circuit 72 | to-expand-arrays 73 | (pass:expand-away-records circuit) 74 | pass:remove-void-bindings 75 | (pass:return-void circuit))) 76 | 77 | (defun to-primitive-circuit (circuit) 78 | (~> circuit 79 | to-expand-away-records 80 | pass:filter-redundant-lets 81 | (pass:primitive-circuit circuit) 82 | pass:rename-primitive-circuit)) 83 | 84 | (defun to-vampir (circuit) 85 | (values 86 | (~> circuit 87 | to-primitive-circuit 88 | pass:circuit-to-alias))) 89 | 90 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 91 | ;; Pipeline For Expressions 92 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 93 | 94 | (-> type-check-expression 95 | (ir:expression alu.typechecker:typing-context) 96 | (values alu.typechecker:typing-context ir:expanded-list)) 97 | (defun type-check-expression (body context) 98 | (let ((body (pass:linearize-body body))) 99 | (values 100 | (check:annotate-list body context) 101 | (remove-if (lambda (p) (typep p 'ir:standalone-ret)) 102 | (pass:remove-type-information body))))) 103 | -------------------------------------------------------------------------------- /src/typechecker/package.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:alu.typechecker.types 3 | (:documentation "Holds the various types needed for the type 4 | checker") 5 | (:local-nicknames (#:ir #:alu.ir) 6 | (#:closure #:alu.closure) 7 | (#:dependency #:alu.closure.dependency) 8 | (#:closure #:alu.closure)) 9 | (:use #:common-lisp #:serapeum) 10 | (:export 11 | ;; Context data type 12 | :typing-context :holes :hole-info :dependency :typing-closure 13 | 14 | ;; Known Type Information 15 | :type-info :type-info-size :type-info-type :type-info-p :make-type-info 16 | 17 | ;; Function return types 18 | :typing-result 19 | 20 | ;; Known Hole Information 21 | :hole-information :hole-information-unrefined :hole-information-term 22 | :make-hole-information :hole-information-p 23 | 24 | :hole 25 | :hole-conditions 26 | :same-as :same-as-value :make-same-as :same-as-p 27 | :depends-on :depends-on-value :make-depends-on :depends-on-p 28 | 29 | ;; Querying information 30 | :current-information 31 | :lookup-type 32 | 33 | ;; Primitive information 34 | :known-primitve-types 35 | :known-primitve-functions 36 | 37 | ;; Operations on Datatypes 38 | :add-hole-formula)) 39 | 40 | (defpackage #:alu.typechecker.size 41 | (:documentation "Calculates the size of various types found in the Alucard 42 | language. The name typically refers to the value being calculated.") 43 | (:local-nicknames (#:ir #:alu.ir) 44 | (#:storage #:alu.storage) 45 | (#:types #:alu.typechecker.types) 46 | (#:log #:alu.log)) 47 | (:shadow :declaration) 48 | (:use #:common-lisp #:serapeum) 49 | (:export 50 | :reference 51 | :storage 52 | :declaration 53 | :declaration-contents 54 | :primitive)) 55 | 56 | ;; This package is split-up between typecheck and unifier 57 | (defpackage #:alu.typechecker.check 58 | (:local-nicknames (#:ir #:alu.ir) 59 | (#:type-op #:alu.spec.type-op) 60 | (#:term-op #:alu.spec.term-op) 61 | (#:closure #:alu.closure) 62 | (#:storage #:alu.storage) 63 | (#:dependency #:alu.closure.dependency) 64 | (#:util #:alu.utils) 65 | (#:size #:alu.typechecker.size) 66 | (#:log #:alu.log)) 67 | (:use #:common-lisp #:serapeum #:alu.typechecker.types) 68 | (:export 69 | :check 70 | :annotate-circuit 71 | :annotate-term 72 | :annotate-list 73 | :make-starting-hole 74 | :type-equality 75 | :solved)) 76 | 77 | (defpackage #:alu.typechecker.intro 78 | (:documentation "Gives an API for introducing new variables to the compiler") 79 | (:local-nicknames (#:ir #:alu.ir) 80 | (#:storage #:alu.storage) 81 | (#:closure #:alu.closure) 82 | (#:dependency #:alu.closure.dependency) 83 | (#:util #:alu.utils) 84 | (#:size #:alu.typechecker.size) 85 | (#:check #:alu.typechecker.check) 86 | (#:log #:alu.log)) 87 | (:use #:common-lisp #:serapeum #:alu.typechecker.types) 88 | (:export 89 | :intro 90 | :with-intro)) 91 | 92 | (uiop:define-package #:alu.typechecker 93 | (:use #:common-lisp 94 | #:serapeum 95 | #:alu.typechecker.types 96 | #:alu.typechecker.check 97 | #:alu.typechecker.intro) 98 | (:reexport #:alu.typechecker.intro) 99 | ;; We don't re-export #:alu.typechecker.check as it has extra 100 | ;; exports we don't want. 101 | (:export 102 | :check 103 | :annotate-circuit 104 | :annotate-term 105 | :annotate-list 106 | :type-equality 107 | :solved) 108 | ;; Operations from types that are good to alias 109 | (:export 110 | ;; Context data type 111 | :typing-context :holes :hole-info :dependency :typing-closure 112 | ;; Known Type Information 113 | :type-info :type-info-size :type-info-type :type-info-p :make-type-info)) 114 | -------------------------------------------------------------------------------- /test/anf.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | 4 | (def-suite alucard.pass.anf 5 | :description "Tests the alucard package") 6 | 7 | (in-suite alucard.pass.anf) 8 | 9 | (test anf-linearizes-application 10 | (let ((normalized 11 | (anf:normalize-expression 12 | (ir:make-application 13 | :function (ir:make-reference :name :hi) 14 | :arguments 15 | (list (ir:make-application 16 | :function (ir:make-reference :name :fun2) 17 | :arguments (list (ir:make-reference :name :hi) 18 | (ir:make-application 19 | :function (ir:make-reference :name :fun3) 20 | :arguments 21 | (list (ir:make-reference :name :hi))))) 22 | (ir:make-reference :name :bob)))))) 23 | ;; We sadly lack object equality for clos classes, so thus we test it this way 24 | (is (= 3 (length normalized)) 25 | "normalization makes a let term over application, at this point 3 times!") 26 | (is (typep (car (last normalized)) 'ir:application) 27 | "After the double let we should have the function application") 28 | (is (eq (ir:name (cadr (ir:arguments (car (last normalized))))) 29 | :bob) 30 | "bob is a straight line argument so it should be unchanged by the transform"))) 31 | 32 | (test anf-linearizes-records 33 | (let* ((normalized 34 | (anf:normalize-expression 35 | (ir:make-application 36 | :function (ir:make-reference :name :hi) 37 | :arguments 38 | (list (ir:make-application 39 | :function (ir:make-reference :name :fun2) 40 | :arguments 41 | (list #1=(ir:make-application 42 | :function (ir:make-reference :name :fun3) 43 | :arguments 44 | (list (ir:make-reference :name :hi))) 45 | (ir:make-record-lookup 46 | :record (ir:make-record :name :utxo 47 | :owner 3 48 | :amount 5 49 | :nonce #1#) 50 | :field :nonce))) 51 | (ir:make-reference :name :bob))))) 52 | (record (ir:value (caddr normalized))) 53 | (lookup (ir:value (cadddr normalized)))) 54 | ;; We sadly lack object equality for clos classes, so thus we test it this way 55 | ;; I really should make equality objects 56 | (is (typep (ir:lookup-record record :nonce) 'ir:reference) 57 | "ANF should have made an application inside the record become a reference") 58 | (is (eq (ir:field lookup) :nonce) 59 | "The field that is looked up should not change") 60 | (is (typep (ir:record lookup) 'ir:reference) 61 | "the record lookup is now over a reference instead of the record directly"))) 62 | 63 | (test anf-constraint 64 | (let* ((normalized (anf:normalize-expression 65 | (ir:make-bind-constraint 66 | :var (list :a :b :c) 67 | :value 68 | (list 69 | (ir:make-application 70 | :function (ir:make-reference :name :=) 71 | :arguments 72 | (list (ir:make-application 73 | :function (ir:make-reference :name :fun2) 74 | :arguments 75 | (list #1=(ir:make-application 76 | :function (ir:make-reference :name :fun3) 77 | :arguments 78 | (list (ir:make-reference :name :hi))) 79 | (ir:make-record-lookup 80 | :record (ir:make-record :name :utxo 81 | :owner 3 82 | :amount 5 83 | :nonce #1#) 84 | :field :nonce))) 85 | (ir:make-reference :name :bob)))))))) 86 | (is (typep normalized 'ir:bind-constraint) 87 | "constraint should hold the terms inside of it") 88 | (is (= 6 (length (ir:value normalized))) 89 | "The body should have ANF successfully run"))) 90 | -------------------------------------------------------------------------------- /test/pass.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (def-suite alucard.pass 4 | :description "Test the compiler pipeline") 5 | 6 | (in-suite alucard.pass) 7 | 8 | (test to-expand-away-records 9 | (let* ((look (pipeline:to-expand-away-records 10 | (storage:lookup-function :record-test))) 11 | (multi-let (remove-if-not (lambda (x) (typep x 'ir:multiple-bind)) 12 | look)) 13 | (multi-ret (remove-if-not (lambda (x) (typep x 'ir:standalone-ret)) 14 | look))) 15 | (is (= 3 16 | (~> multi-let car ir:value ir:arguments length)) 17 | "The point type should expand into two arguments") 18 | (is (= 4 (length (ir:var (car multi-ret)))) 19 | "The nested type should be expanded into output"))) 20 | 21 | (test to-expand-away-records-intermediate 22 | (let* ((look (pipeline:to-expand-away-records 23 | (storage:lookup-function :record-test-mult))) 24 | (multi-lets (remove-if-not (lambda (x) (typep x 'ir:multiple-bind)) 25 | look)) 26 | (returns (remove-if-not (lambda (x) (typep x 'ir:standalone-ret)) 27 | look))) 28 | (is (= 3 29 | (~> multi-lets car ir:value ir:arguments length)) 30 | "The point type should expand into two arguments") 31 | (is (= 2 (length (ir:var (car returns)))) 32 | "The nested type should be expanded into output"))) 33 | 34 | (test void-removal 35 | (let ((ran (pipeline:to-expand-away-records 36 | (storage:lookup-function :use-constrain)))) 37 | (is (= 2 (length ran))) 38 | (is (equalp nil (ir:var (cadr ran)))))) 39 | 40 | (test renaming 41 | (let ((ran (pipeline:to-primitive-circuit (storage:lookup-function :record-test))) 42 | (ran2 (pipeline:to-primitive-circuit (storage:lookup-function :record-test-mult))) 43 | (ran3 (pipeline:to-primitive-circuit (storage:lookup-function :use-constrain)))) 44 | ran2 ran3 45 | (is (every (lambda (x) 46 | (not 47 | (or (string-contains-p "&" x) 48 | (string-contains-p "-" x) 49 | (string-contains-p "%" x)))) 50 | (ir:returns ran))))) 51 | 52 | (test trans-let 53 | (let ((term 54 | (ir:make-bind-constraint 55 | :var (list :a :b :c) 56 | :value 57 | (list 58 | (ir:make-application 59 | :function (ir:make-reference :name :=) 60 | :arguments 61 | (list (ir:make-application 62 | :function (ir:make-reference :name :fun2) 63 | :arguments 64 | (list #1=(ir:make-application 65 | :function (ir:make-reference :name :fun3) 66 | :arguments 67 | (list (ir:make-reference :name :hi))) 68 | (ir:make-record-lookup 69 | :record (ir:make-record :name :utxo 70 | :owner 3 71 | :amount 5 72 | :nonce #1#) 73 | :field :nonce))) 74 | (ir:make-reference :name :bob))))))) 75 | (is 76 | ;; the type check is good enough to ensure that the pass works! 77 | (typep (alu.pass::transform-let (anf:normalize-expression term)) 78 | 'ir:constraint-list)))) 79 | 80 | (test constrain-example 81 | (let* ((circuit (storage:lookup-function :manual-constraint)) 82 | (linear (pass:linearize circuit)) 83 | (record (pass:expand-away-records linear circuit))) 84 | (is (equalp (ir:var (car (last linear))) 85 | (list :a :b :c)) 86 | "The values in the constraint are returned if they are the last value") 87 | (is (typep (ir:value (car record)) 'ir:fully-expanded-list)))) 88 | 89 | (test standalone-ret-expansion 90 | (let* ((circuit (storage:lookup-function :record-ret)) 91 | (expanded (pipeline:to-expand-away-records circuit))) 92 | (is (< 1 (length (ir:var (car (last expanded)))))))) 93 | 94 | (test extraction 95 | (finishes (pipeline:pipeline (storage:lookup-function :poly-check))) 96 | (finishes (pipeline:pipeline (storage:lookup-function :record-test-mult))) 97 | (finishes (pipeline:pipeline (storage:lookup-function :array-lookup-equation))) 98 | (finishes (pipeline:pipeline (storage:lookup-function :explicit-type-coercsion))) 99 | (finishes (pipeline:pipeline (storage:lookup-function :explicit-type-check))) 100 | (finishes (pipeline:pipeline (storage:lookup-function :array-from-data-check))) 101 | ;; We should make a more full test for this 102 | (finishes (pipeline:pipeline (storage:lookup-function :silly-range-check)))) 103 | -------------------------------------------------------------------------------- /alu/example.lisp: -------------------------------------------------------------------------------- 1 | (in-package :aluser) 2 | 3 | ;; 4 | (deftype utxo () 5 | (owner (bytes 128)) 6 | (amount (int 64)) 7 | (nonce (int 64))) 8 | 9 | ;; let us not support recursive data types at first 10 | (deftype (merkle-branch :unroll 10) () 11 | (hash (bytes 64)) 12 | (left merkle-branch) 13 | (right merkle-branch)) 14 | 15 | (deftype point () 16 | (x int) 17 | (y int)) 18 | 19 | (deftype nested () 20 | (plane point) 21 | (time point)) 22 | 23 | (defcircuit constrain ((public nest nested) 24 | (output bool)) 25 | (def ((plane (plane nest)) 26 | (time (time nest))) 27 | (= (* (x plane) 28 | (y plane)) 29 | (* (x time) 30 | (y time))))) 31 | 32 | (defcircuit constrain-2 ((public nest nested) 33 | (output void)) 34 | (flet ((formula (point) 35 | (* (x point) 36 | (y point)))) 37 | (= (formula (plane nest)) 38 | (formula (time nest))))) 39 | 40 | (defcircuit constrain-3 ((public nest nested) 41 | (output void)) 42 | (reduce #'= 43 | (mapcar (lambda (point) 44 | (* (x point) 45 | (y point))) 46 | (list (plane nest) (time nest))))) 47 | 48 | 49 | 50 | (defcircuit range-check-1 ((private input int) 51 | (output void)) 52 | (def ((with-constraint (b1 b0) 53 | (= input (+ b1 b0)))) 54 | b1)) 55 | 56 | (defcircuit imperative-example ((private input int) 57 | (output int)) 58 | (add-to 300 input)) 59 | 60 | (defun add-to (x vampir-value) 61 | (let ((accumulator vampir-value)) 62 | (loop for i from 0 to x 63 | do (setf accumulator (+ i accumulator))) 64 | accumulator)) 65 | 66 | (defcircuit functional-example ((output int)) 67 | (reduce (lambda (x y) (+ x y)) (alexandria:iota 10) :initial-value 0)) 68 | 69 | ;; (alu::let-refs (b0 b1) 70 | ;; (alu::with-constraint-standalone (b0 b1) (= input (+ b1 b0))) 71 | ;; (list)) 72 | 73 | (def ((a 3) 74 | (b 5)) 75 | a) 76 | 77 | (defcircuit root-test ((public x int)) 78 | (= (+ (exp x 3) 79 | (* 3 (exp x 2)) 80 | (* 2 x) 81 | 4) 82 | 0)) 83 | 84 | ;; Note from Chris, something like 85 | ;; (defun poly-check (x int) (= (+ (exp x 3) (mul 3 (exp x 2)) (mul 2 x) 4) 0) 86 | ;; is wanted, so we can skimp on the `public` and make more short hands thereof 87 | 88 | ;; Discussion 89 | ;; maybe : Add casting functions to add more constraints into a circuit input 90 | ;; want : explicit defconstraint macro that adds constraints to values (monotonically increasing information) 91 | 92 | (defcircuit poly-check ((public x int) 93 | (output bool)) 94 | (= (+ (exp x 3) 95 | (* 3 (exp x 2)) 96 | (* 2 x) 97 | 4) 98 | 0)) 99 | 100 | ;; (defcircuit constraint ((public const (bytes 64)) 101 | ;; (output int)) 102 | ;; (def ((a (= (+ const 53) 0)) 103 | ;; (b (range 32 a))) 104 | ;; (and (range 64 a) 105 | ;; b))) 106 | 107 | ;; Something like this happens quite often when writing big hash 108 | ;; function cirucits... how do we organize information properly 109 | 110 | ;; This is rounded, same logic, different constants. 111 | ;; A function apply it 20 functions, in variations 112 | ;; 1. constant known to the entire world 113 | ;; every round it's a little different 114 | ;; (defun orgnaize-circuit-infomration-nicely (data) 115 | ;; (fold #'list 116 | ;; (concatenate-in-tree 117 | ;; (shuffle 118 | ;; (list data-bytes-bits-whatever))))) 119 | 120 | ;; Nice idea 121 | ;; Generate out diagrams arrows between data types 122 | ;; How things are related 123 | 124 | 125 | (defcircuit poly ((public root (bytes 64)) 126 | (private sig (bytes 64)) 127 | (private utxo utxo) 128 | ;; should consider doing the unrolling here rather than 129 | (private merk merkle-branch) 130 | ;; should we have return type information be here 131 | (output int)) 132 | ;; (fold-tree root merk) 133 | ;; (equal (owner utxo) "test") 134 | (= (owner utxo) 5)) 135 | 136 | ;; (entry-point constrain-3) 137 | 138 | 139 | (defcircuit multivar ((public x int) 140 | (public y int) 141 | (output int)) 142 | (= (+ (exp x 3) 143 | (* 3 (exp x 2)) 144 | (* 2 x) 145 | (* 3 y) 146 | 4) 147 | 0)) 148 | 149 | (defcircuit square-root ((private p int) 150 | (output int)) 151 | (def ((with-constraint (x) 152 | (= p (* x x)))) 153 | x)) 154 | 155 | (defun square (cord) 156 | (exp cord 2)) 157 | 158 | (defcircuit distance ((public pt point) 159 | (output int)) 160 | (square-root (+ (square (x pt)) 161 | (square (y pt))))) 162 | 163 | (entry-point distance) 164 | -------------------------------------------------------------------------------- /src/vampir/vampir.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.vampir) 2 | 3 | ;; We use CL streams as they are much better for concatenating to, and 4 | ;; have us worry less. they are a mutable interface however. 5 | 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | ;; FORMAT RUNDOWN FOR THOSE WHO ARE UNFAMILIAR 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;; https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node257.html 11 | 12 | ;; DSL FOR NEWLINES AND CONTROL OF IT 13 | 14 | ;; ~4I = (pprint-indent :block 4) 15 | ;; ~4:I = (pprint-indent :current 4) 16 | ;; ~_ = (pprint-newline :linear) 17 | ;; ~@_ = (pprint-newline :miser) 18 | ;; ~:@_ = (pprint-newline :mandatory) 19 | ;; ~:_ = (pprint-newline :fill) 20 | 21 | 22 | ;; FOR PRINTING NORMALLY NOTE THESE TAKE ARGUMENTS! 23 | 24 | ;; ~(~a~) = print symbol lower case instead of upper case 25 | ;; ~{~A~} = prints a list element by element. 26 | 27 | ;; ~{~A~^ ~} = prints a list element by element, the last element of 28 | ;; the list does not print the extra space 29 | ;; EXAMPLE: 30 | ;; VAMPIR> (format nil "~{~A~^ ~}" (list 1 2 3 4 5)) 31 | ;; "1 2 3 4 5" 32 | ;; VAMPIR> (format nil "~{~A ~}" (list 1 2 3 4 5)) 33 | ;; "1 2 3 4 5 " 34 | 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | ;; TopLevel Extraction 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | 39 | (-> extract (list &optional stream) stream) 40 | (defun extract (stmts &optional (stream *standard-output*)) 41 | (let ((*print-pretty* t) 42 | (*print-miser-width* 40)) 43 | (format stream "~{~A~^~%~}" stmts)) 44 | stream) 45 | 46 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 | ;; Statement Extraction 48 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | 50 | (defmethod print-object ((pub spc:pub) stream) 51 | (pprint-logical-block (stream nil) 52 | (format stream "~I~{pub ~(~a~)~^~:@_~}" (spc:wires pub)))) 53 | 54 | (defmethod print-object ((alias spc:alias) stream) 55 | (pprint-logical-block (stream nil) 56 | (format stream "def ~(~a~)" (spc:name alias)) 57 | (format stream "~4I~{ ~@_~(~a~)~} " (spc:inputs alias)) 58 | 59 | ;; no more output circuits, but may it rest here 60 | ;; (when (spc:outputs alias) 61 | ;; (format stream "~@_->~{ ~@_~(~a~)~} " (spc:outputs alias))) 62 | 63 | (format stream "~0I~@_{~2I") 64 | (extract-constraint-list (spc:body alias) stream) 65 | (format stream "~0I~:@_}"))) 66 | 67 | (-> extract-constraint-list (spc:constraint-list &optional stream) stream) 68 | (defun extract-constraint-list (cs &optional (stream *standard-output*)) 69 | (format stream "~{~:@_~A~^;~}" cs) 70 | stream) 71 | 72 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 73 | ;; Constraint Extraction 74 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 75 | 76 | (defmethod print-object ((bind spc:bind) stream) 77 | (pprint-logical-block (stream nil) 78 | (cond ((cdr (spc:names bind)) 79 | (format stream "def (~{~A~^, ~}) = " (spc:names bind))) 80 | ((spc:names bind) 81 | (format stream "def ~{~A~^, ~} = " (spc:names bind)))) 82 | (format stream "~2I~_~A" (spc:value bind)))) 83 | 84 | (defmethod print-object ((eql spc:equality) stream) 85 | (pprint-logical-block (stream nil) 86 | (format stream "~A ~2:I= ~4I~@_~A" (spc:lhs eql) (spc:rhs eql)))) 87 | 88 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 89 | ;; Expression Extraction 90 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 91 | 92 | (-> extract-expression (spc:expression &optional stream) stream) 93 | (defun extract-expression (expr &optional (stream *standard-output*)) 94 | "Extract-expression is like a `print-object' but adds an extra set 95 | of ()'s for any non normal form" 96 | (etypecase-of spc:expression expr 97 | (spc:infix 98 | (pprint-logical-block (stream nil :prefix "(" :suffix ")") 99 | (print-object expr stream))) 100 | (spc:application 101 | (pprint-logical-block (stream nil :prefix "(" :suffix ")") 102 | (print-object expr stream))) 103 | ((or spc:tuple spc:normal-form) 104 | (print-object expr stream))) 105 | stream) 106 | 107 | (defmethod print-object ((infix spc:infix) stream) 108 | (extract-expression (spc:lhs infix) stream) 109 | (format stream " ~A " (spc:op infix)) 110 | (extract-expression (spc:rhs infix) stream)) 111 | 112 | (defmethod print-object ((application spc:application) stream) 113 | (format stream "~(~a~)" (spc:func application)) 114 | ;; put fill printing? 115 | (dolist (expr (spc:arguments application)) 116 | (format stream " ") 117 | (extract-expression expr stream))) 118 | 119 | (defmethod print-object ((wire spc:wire) stream) 120 | (format stream "~(~a~)" (spc:var wire))) 121 | 122 | (defmethod print-object ((tup spc:tuple) stream) 123 | (pprint-logical-block (stream nil :prefix "(" :suffix ")") 124 | (format stream "~{~(~a~)~^, ~}" (spc:wires tup)))) 125 | 126 | (defmethod print-object ((const spc:constant) stream) 127 | (format stream "~A" (spc:const const))) 128 | -------------------------------------------------------------------------------- /src/pass/extract.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.pass.extract) 2 | 3 | (-> circuit-to-alias (ir:prim-circuit) spc:alias) 4 | (defun circuit-to-alias (circuit) 5 | (with-accessors ((name ir:name) (arguments ir:arguments) (body ir:body)) circuit 6 | (values 7 | (spc:make-alias :name name 8 | :inputs arguments 9 | :body (mapcan #'term->constraint body))))) 10 | 11 | (-> term->constraint (ir:fully-expanded-term) spc:constraint-list) 12 | (defun term->constraint (term) 13 | (labels ((keywords->wire (keys) 14 | (mapcar (lambda (x) (spc:make-wire :var x)) keys)) 15 | (var-val->bind (term) 16 | (let ((value (ir:value term)) 17 | (names (keywords->wire (if (listp (ir:var term)) 18 | (ir:var term) 19 | (list (ir:var term)))))) 20 | (if (not (equality-check value)) 21 | (list 22 | (spc:make-bind :names names 23 | :value (term->expression value))) 24 | ;; This entire thing is a hack, please do better! 25 | 26 | ;; this will have to hit the app->constraint case! 27 | ;; as it's an equality application! 28 | (let ((equality (app->constraint value))) 29 | (list equality 30 | ;; should only be one as it's a 31 | (spc:make-bind :names names 32 | :value (spc:lhs equality)))))))) 33 | (values 34 | (etypecase-of ir:fully-expanded-term term 35 | ;; drop standalone constants, we can't emit it! 36 | (ir:standalone-ret (list (return->expression term))) 37 | ;; (ir:application (list (app->constraint term))) 38 | (ir:bind-constraint (mapcan #'term->constraint (ir:value term))) 39 | (ir:bind (var-val->bind term)) 40 | (ir:multiple-bind (var-val->bind term)))))) 41 | 42 | (-> return->expression (ir:standalone-ret) (or spc:wire spc:tuple)) 43 | (defun return->expression (ret) 44 | (values 45 | (let ((wires (ir:var ret))) 46 | (if (or (null wires) (cdr wires)) 47 | (spc:make-tuples :wires wires) 48 | (spc:make-wire :var (car wires)))))) 49 | 50 | (-> term->expression ((or ir:term-normal-form ir:application)) spc:expression) 51 | (defun term->expression (app-norm) 52 | (etypecase-of (or ir:term-normal-form ir:application) app-norm 53 | (ir:application (app->expression app-norm)) 54 | (ir:term-normal-form (normal-form->normal-form app-norm)))) 55 | 56 | (-> normal-form->normal-form (ir:term-normal-form) spc:normal-form) 57 | (defun normal-form->normal-form (anormal) 58 | (assure spc:normal-form 59 | (etypecase-of ir:term-normal-form anormal 60 | (number (spc:make-constant :const anormal)) 61 | (ir:reference (spc:make-wire :var (ir:name anormal)))))) 62 | 63 | 64 | (-> app->constraint (ir:application) spc:constraint) 65 | (defun app->constraint (app) 66 | (let ((looked (storage:lookup-function (ir:name (ir:func app)))) 67 | (deal-args (mapcar #'normal-form->normal-form (ir:arguments app)))) 68 | (values 69 | (etypecase-of ir:function-type looked 70 | (ir:circuit 71 | (spc:make-application :func (ir:name (ir:func app)) 72 | :arguments deal-args)) 73 | (ir:primitive 74 | (cond ((not (eql (ir:name looked) :=)) 75 | (error "an infix expression is not a valid constraint")) 76 | ;; we should probably make = take n arguments were we can fold it 77 | ((= (length deal-args) 2) 78 | (spc:make-equality :lhs (car deal-args) 79 | :rhs (cadr deal-args))) 80 | (t 81 | (error 82 | (format nil 83 | "= can only be applied to 2 arguments but is applied to: ~A~%" 84 | (length deal-args)))))))))) 85 | 86 | (-> app->expression (ir:application) spc:expression) 87 | (defun app->expression (app) 88 | (let ((looked (storage:lookup-function (ir:name (ir:func app)))) 89 | (deal-args (mapcar #'normal-form->normal-form (ir:arguments app)))) 90 | (values 91 | (if (typep looked 'ir:primitive) 92 | ;; circuits are easy, as it's a straightforward mapping! 93 | (prim->app (alucard-prim->vampir-name (ir:name looked)) deal-args) 94 | (spc:make-application :func (ir:name (ir:func app)) 95 | :arguments deal-args))))) 96 | 97 | 98 | (-> prim->app (keyword list) spc:infix) 99 | (defun prim->app (key args) 100 | (if (and (not (typep key 'spc:primitive)) (= 0 (length args))) 101 | (error "primitive functions require 2 arguments") 102 | (reduce (lambda (lhs rhs) 103 | (spc:make-infix :lhs lhs :op key :rhs rhs)) 104 | args 105 | :from-end t))) 106 | 107 | (-> alucard-prim->vampir-name (keyword) keyword) 108 | (defun alucard-prim->vampir-name (keyword) 109 | (case keyword 110 | (:exp :^) 111 | (t keyword))) 112 | 113 | (defun equality-check (term) 114 | (and (typep term 'ir:application) 115 | (eql (ir:name (ir:func term)) :=))) 116 | -------------------------------------------------------------------------------- /src/spec/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:alu.spec 2 | (:documentation "the type specification and layout of the alu 3 | package and alu terms") 4 | (:use #:common-lisp #:serapeum) 5 | (:local-nicknames (:util :alu.utils) 6 | (:stack :alu.stack)) 7 | (:export 8 | 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | ;;; Mixin Services 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | 13 | ;; Generic Data Manipulation 14 | :direct-slots-mixin 15 | :protect-slots-mixin 16 | 17 | ;; Meta data information 18 | :stack-mixin 19 | :meta-mixin 20 | 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | ;; Operations on data traversal 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | :protected 25 | :protect-slots 26 | :direct-slots 27 | :direct-slot-names 28 | :direct-slot-keywords 29 | :direct-slot-values 30 | :update-from-alist 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | ;; Operations on meta data 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | :stack 36 | :copy-meta 37 | 38 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 39 | ;; found in term 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | 42 | ;; New Top Level Term Variants Defined 43 | :expression 44 | :term 45 | :term-no-binding 46 | :base 47 | :type-manipulation 48 | :term-type-manipulation 49 | :record-forms 50 | :array-forms 51 | :term-normal-form 52 | 53 | ;; Term ADT Constructors Defined 54 | :application :func :arguments 55 | :primitive :name 56 | :record :name :contents 57 | :record-lookup :record :field 58 | :let-node :var :value 59 | :reference :name 60 | :bind-constraint :var :value 61 | :type-coerce :value :typ 62 | :type-check :value :typ 63 | :from-data :contents 64 | :array-allocate :size :typ 65 | :array-lookup :arr :pos 66 | :array-set :arr :pos :value 67 | 68 | ;; Term Applications Defined 69 | :make-application 70 | :make-record :lookup-record :make-record-lookup 71 | :make-type-check :make-type-coerce 72 | :make-from-data :make-array-allocate :make-array-lookup :make-array-set 73 | :make-let :make-reference :make-bind-constraint 74 | 75 | ;; Functions 76 | :record->alist 77 | 78 | ;; Misc pattern matching functions 79 | :number 80 | 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | ;;; found in type 83 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 84 | 85 | ;; New Top Level Term Variants Defined 86 | :type-reference 87 | :type-reference-full 88 | 89 | ;; New Types Defined Type-Storage 90 | :reference-type :name 91 | 92 | ;; New Array Abstractions 93 | :array-type :array-type-len :array-type-content 94 | 95 | ;; Functions 96 | :to-type-reference-format 97 | 98 | ;; New Constructors Defined 99 | :make-type-reference :make-primitive 100 | :make-type-declaration :make-record-declaration 101 | 102 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 103 | ;; found in global 104 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105 | 106 | ;; New Top Level Term Variants Defined 107 | :function-type 108 | :type-storage 109 | 110 | ;; New Types Defined Function-type 111 | :circuit :name :arguments :expanded-arguments :return-type :body :exec 112 | 113 | :privacy 114 | :constraint :name :typ 115 | 116 | ;; New Types Defined Type-Storage 117 | :type-declaration :name :generics :options :decl 118 | 119 | :type-format 120 | :record-decl :contents :order 121 | :sum-decl 122 | 123 | ;; Functions 124 | :record-declaration->alist 125 | 126 | ;; New Constructors Defined 127 | :make-circuit 128 | :make-constraint)) 129 | 130 | (defpackage #:alu.storage 131 | (:documentation "Serves as the long term storage of any Alucard Circuit") 132 | (:use #:common-lisp #:serapeum) 133 | (:local-nicknames (:format :alu.spec)) 134 | (:export 135 | :*types* 136 | :*functions* 137 | :add-function :add-type 138 | :lookup-function :lookup-type 139 | :swap-tables :restore-tables 140 | :currently-swapped? 141 | ;; Entry point operations 142 | :get-entry-point 143 | :set-entry-point)) 144 | 145 | (defpackage #:alu.spec.emit 146 | (:documentation "Emits to the real body of a circuit declaration. By this, we mean 147 | that we modify the current body in scope with the given instruction.") 148 | (:use #:common-lisp #:serapeum) 149 | (:local-nicknames (:spc :alu.spec) 150 | (:storage :alu.storage)) 151 | (:export :with-circuit-body :instruction)) 152 | 153 | (defpackage #:alu.spec.type-op 154 | (:documentation "Provides basic operations on types") 155 | (:use #:common-lisp #:serapeum) 156 | (:local-nicknames (:spc :alu.spec) 157 | (:storage :alu.storage)) 158 | (:export :primitive? :array-reference? :void-reference? :int-reference? 159 | :record-reference?)) 160 | 161 | (defpackage #:alu.spec.term-op 162 | (:documentation "Provides basic operations on types") 163 | (:shadow :exp :coerce :=) 164 | (:use #:common-lisp #:serapeum) 165 | (:local-nicknames (:spc :alu.spec) 166 | (:storage :alu.storage)) 167 | (:export :add :times :exp :coerce := :void-reference?)) 168 | -------------------------------------------------------------------------------- /src/stack/stack.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.stack) 2 | 3 | (defclass stack () 4 | ((current-section 5 | :initarg :current-section 6 | :accessor current-section 7 | :type (or null section) 8 | :initform nil 9 | :documentation "the current section to push into if there even is one") 10 | (stack :initarg :stack 11 | :initform nil 12 | :accessor stack 13 | :type list 14 | :documentation "The Current calls "))) 15 | 16 | (defclass section () 17 | ((name :initarg :name 18 | :initform :section 19 | :accessor name 20 | :type symbol 21 | :documentation "The name of the current section") 22 | (stack :initarg :stack 23 | :initform nil 24 | :accessor stack 25 | :type list))) 26 | 27 | (defmethod print-object ((obj stack) stream) 28 | (pprint-logical-block (stream nil :prefix "(" :suffix ")") 29 | (when (current-section obj) 30 | (format stream "~A" (current-section obj)) 31 | (when (stack obj) 32 | (format stream "~:@_"))) 33 | (format stream "~{~A~^~:@_~}" (stack obj)))) 34 | 35 | (defmethod print-object ((obj section) stream) 36 | (pprint-logical-block (stream nil :prefix "(" :suffix ")") 37 | (format stream ":IN ~A" (name obj)) 38 | (format stream "~{~:@_~A~^~}" (stack obj)))) 39 | 40 | (defparameter *stack* (ref:ref (make-instance 'stack)) 41 | "Global stack that operands will be pushed to") 42 | 43 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 44 | ;; Mutable interface toe the functional data structure 45 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 46 | 47 | (defun push (x &optional (stack *stack*)) 48 | (setf (ref:! stack) 49 | (cons x (ref:! stack)))) 50 | 51 | (-> push-section (symbol &optional ref:ref) stack) 52 | (defun push-section (name &optional (stack *stack*)) 53 | (setf (ref:! stack) 54 | (new-section name (ref:! stack)))) 55 | 56 | (defun pop (&optional (stack *stack*)) 57 | (setf (ref:! stack) 58 | (cdr (ref:! stack)))) 59 | 60 | (-> pop-section (&optional ref:ref) stack) 61 | (defun pop-section (&optional (stack *stack*)) 62 | (setf (ref:! stack) 63 | (cdr-current-section (ref:! stack)))) 64 | 65 | (defun get (&optional (stack *stack*)) 66 | (ref:! stack)) 67 | 68 | (defun new () 69 | (ref:ref (make-instance 'stack))) 70 | 71 | (defmacro with-empty-stack (() &rest body) 72 | `(let ((*stack* (new))) 73 | ,@body)) 74 | 75 | (defmacro with-section (name &rest body) 76 | `(unwind-protect (progn (push-section ',name) 77 | ,@body) 78 | (pop-section))) 79 | 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | ;; Pure functions on stacks 82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 83 | 84 | (-> emptyp (stack) boolean) 85 | (defun emptyp (stack) 86 | (with-accessors ((stack stack) (current current-section)) stack 87 | (and (null stack) 88 | (null current)))) 89 | 90 | (-> new-section (symbol stack) stack) 91 | (defun new-section (name stack) 92 | (with-accessors ((stack stack) (current current-section)) stack 93 | (let ((new-stack 94 | (if current 95 | (cl:cons current stack) 96 | stack))) 97 | (make-instance 'stack :stack new-stack 98 | :current-section (make-instance 'section :name name))))) 99 | 100 | (-> cons (t stack) stack) 101 | (defun cons (x stack) 102 | (with-accessors ((stack stack) (current current-section)) stack 103 | (if current 104 | (make-instance 'stack :stack stack 105 | :current-section (cons-section x current)) 106 | (make-instance 'stack :stack (cl:cons x stack) 107 | :current-section current)))) 108 | (-> cdr (stack) stack) 109 | (defun cdr (stack) 110 | (with-accessors ((stack stack) (current current-section)) stack 111 | (cond ((and current (not (null (stack current)))) 112 | (make-instance 'stack :stack stack 113 | :current-section (cdr-section current))) 114 | (current 115 | (make-instance 'stack :stack stack 116 | :current-section nil)) 117 | ((typep (car stack) 'section) 118 | (cdr (make-instance 'stack :stack (cl:cdr stack) 119 | :current-section (car stack)))) 120 | (t 121 | (make-instance 'stack :stack (cl:cdr stack) 122 | :current-section nil))))) 123 | 124 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 125 | ;; Functions on Sections 126 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 127 | 128 | (-> cons-section (t section) section) 129 | (defun cons-section (x section) 130 | (with-accessors ((name name) (stack stack)) section 131 | (make-instance 'section :stack (cl:cons x stack) :name name))) 132 | 133 | (-> cdr-section (section) section) 134 | (defun cdr-section (section) 135 | (with-accessors ((name name) (stack stack)) section 136 | (make-instance 'section :stack (cl:cdr stack) :name name))) 137 | 138 | 139 | (-> cdr-current-section (stack) stack) 140 | (defun cdr-current-section (stack) 141 | (with-accessors ((stack stack)) stack 142 | (if (typep (car stack) 'section) 143 | (make-instance 'stack :stack (cl:cdr stack) 144 | :current-section (car stack)) 145 | (make-instance 'stack :stack stack 146 | :current-section nil)))) 147 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * Alu 2 | ** Description 3 | ALucard (Alu) is a high level DSL for writing [[https://en.wikipedia.org/wiki/Zero-knowledge_proof][Zero Knowledge]] 4 | circuits. Alu compiles to a constraint agnostic system known as 5 | [[https://github.com/ZK-Garage/vamp-ir][vamp-ir]] which allows easy integration and deployment into existing 6 | Zero Knowledge stacks or private applications into new systems. 7 | 8 | Since Alu is a DSL, it's syntax is heavily inspired from it's host 9 | language [[https://common-lisp.net/][Common lisp]], extending the language with circuit compilation 10 | capabilities. This means that Alucard can use language infrastructure 11 | like [[https://fiveam.common-lisp.dev/][FiveAM]] and [[https://www.cliki.net/SWANK][SWANK]] to allow a battle tested interactive developer 12 | experience. 13 | ** Quick Start 14 | [[https://hackmd.io/KTN_7tyGTe2RvJ5-aC4rBw][A friendly introduction can be found here]] 15 | ** Documentation 16 | The most complete documentation is the [[https://hackmd.io/emeUBiYoSqmJ95Ls2wsrMQ][Alucard Reference Manual]]. 17 | 18 | - [[https://hackmd.io/emeUBiYoSqmJ95Ls2wsrMQ][Reference Manual]] 19 | - [[file:doc/spec.md][Specification]] 20 | - [[file:doc/using-alucard.md][Syntax Guide]] 21 | 22 | For those curious about test coverage, the test coverage of the 23 | compiler can be found [[https://anoma.github.io/juvix-circuits/][here]]. 24 | ** Editor Integration 25 | Since Alucard Relies on Common lisp, we support all major editors. For 26 | the best experience Emacs is recommend though the other editors work 27 | well! 28 | *** Emacs 29 | With Emacs you have a few choices for easy editor integration, either: 30 | - [[https://github.com/joaotavora/sly][Sly]] 31 | - [[https://github.com/slime/slime][Slime]] 32 | 33 | Then you just have to set the default lisp program to alucard. 34 | #+begin_src lisp 35 | (setq inferior-lisp-program "alu.image") 36 | #+end_src 37 | 38 | If you don't wish for the default implementation to be alucard, then 39 | =alu.image= can be passed in manually when calling =M-x sly= (In helm 40 | this is =C-u= before running the command) 41 | *** VSCode 42 | [[https://lispcookbook.github.io/cl-cookbook/vscode-alive.html][Alive]] 43 | 44 | With [[https://lispcookbook.github.io/cl-cookbook/vscode-alive.html][Alive]] Alucard integration is quite simple, just grab the 45 | extension off the marketplace and then edit the settings.json with 46 | 47 | However the following dependencies will also be needed 48 | - [[https://github.com/nobody-famous/alive-lsp][alive-lsp]] 49 | + This can be installed with 50 | + =ros install "nobody-famous/alive-lsp"= 51 | 52 | #+begin_src javascript 53 | { 54 | "alive.lsp.startCommand": [ 55 | "alu.image", 56 | "-a" 57 | ] 58 | } 59 | #+end_src 60 | 61 | when now connecting to a =.lisp= file, alucard will automatically be 62 | booted up. Note that to get =alucard= in the right package, in the 63 | bottom left prompt in the =REPL= tab, you should click on the 64 | =cl-user= and type in =aluser= to set the system in the right package. 65 | *** Vim 66 | [[https://github.com/vlime/vlime][vlime]] 67 | [TODO] 68 | *** Terminal 69 | Alucard can be launched from the terminal and attach to your editor as 70 | well. This can be done by launching the program with =-s= for swank or 71 | =-y= for sly. Once done you should be given a REPL on the terminal 72 | along with the message 73 | #+begin_src lisp 74 | ;; Swank started at port: 4005. 75 | #+end_src 76 | This means that you can hookup your editor of choice to localhost:4005 77 | via =sly-connect= or =alive attach to REPL=. 78 | ** For Developers 79 | *** Test Coverage 80 | - Test coverage can be found [[https://anoma.github.io/juvix-circuits/][here]]. 81 | *** Setting up the Developer Environment 82 | _Alucard works on many different implementations of CL, namely_ 83 | + SBCL 84 | + CCL 85 | + ECL 86 | 87 | To quickly get started with Alucard development, one can run the 88 | following commands from their lisp REPL 89 | 90 | - =(load "alu.asd")= 91 | - =(ql:quickload :alu/test)= 92 | + If one is using =CLPM= then you should run =(activate-project)= 93 | instead. 94 | - =(asdf:test-system :alu)= 95 | 96 | If there was an error in the above commands, look at the section below 97 | for some common solutions. 98 | 99 | If the commands work, then you can start hacking on Alucard! 100 | 101 | Currently binary extraction does not work with SBCL, but it is 102 | perfectly fit to load the environment like any normal CL library! 103 | 104 | **** Errors with SBCL 105 | SBCL by default does not ship a new enough version of ASDF, and you 106 | may encounter an error like 107 | #+begin_src lisp 108 | * (ql:quickload :alu) 109 | 110 | debugger invoked on a ASDF/FIND-COMPONENT:MISSING-DEPENDENCY-OF-VERSION in thread 111 | #: 112 | Component "asdf" does not match version 3.3.5, required by # 113 | 114 | Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL. 115 | 116 | restarts (invokable by number or by possibly-abbreviated name): 117 | 0: [ABORT ] Give up on "alu" 118 | 1: [REGISTER-LOCAL-PROJECTS] Register local projects and try again. 119 | 2: Exit debugger, returning to top level. 120 | 121 | (QUICKLISP-CLIENT::AUTOLOAD-SYSTEM-AND-DEPENDENCIES "alu" :PROMPT NIL) 122 | source: (ERROR C) 123 | #+end_src 124 | If this occurs you may need to update your asdf to a newer version. 125 | 126 | 1. Clone the repo: =git clone https://gitlab.common-lisp.net/asdf/asdf.git= 127 | 2. =cd asdf= 128 | 3. =git checkout 3.3.5.8= ([[https://gitlab.common-lisp.net/asdf/asdf/-/tags][any tag in =3.3.5.*= works]]) 129 | 4. =make= 130 | 5. In the lisp REPL: =(load "/path/to/asdf/build/asdf.lisp")= 131 | 6. put =(load "/path/to/asdf/build/asdf.lisp")= in your =~/.sbclrc= 132 | 7. rerun the command that triggered the error 133 | -------------------------------------------------------------------------------- /src/intermediate/spec.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.ir.spec) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; IR Variants through the pipeline 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | ;; The Pipeline for how these types get used is roughly as follows. 8 | ;; 9 | ;; +-----------------------------------+ 10 | ;; | Linear-Term | 11 | ;; +-----------------------------------+ 12 | ;; | Alu Term through ANF | 13 | ;; | | 14 | ;; | Binders contain term-type-manip… | 15 | ;; | | 16 | ;; | No other changes | 17 | ;; | | 18 | ;; +-----------------------------------+ 19 | ;; | 20 | ;; | 21 | ;; v 22 | ;; +-----------------------------------+ 23 | ;; | Type Aware Term | 24 | ;; +-----------------------------------+ 25 | ;; | Term through removal of top level | 26 | ;; | normal form | 27 | ;; | | 28 | ;; | Binders contain term-type-manip… | 29 | ;; | | 30 | ;; | | 31 | ;; | We run algorithms like | 32 | ;; | - type checking | 33 | ;; | - Expansion | 34 | ;; | - ETC | 35 | ;; +-----------------------------------+ 36 | ;; | 37 | ;; | 38 | ;; v 39 | ;; +-----------------------------------+ 40 | ;; | Expanded-Term | 41 | ;; +-----------------------------------+ 42 | ;; | Term through removal of top level | 43 | ;; | normal forms | 44 | ;; | | 45 | ;; | Binders contain term-no-binders | 46 | ;; | | 47 | ;; | | 48 | ;; | We run algorithms like | 49 | ;; | - type checking | 50 | ;; | - Expansion | 51 | ;; | - ETC | 52 | ;; +-----------------------------------+ 53 | ;; | 54 | ;; | 55 | ;; v 56 | ;; +-----------------------------------+ 57 | ;; | Fully-Expanded-Term | 58 | ;; +-----------------------------------+ 59 | ;; | Term where concepts like | 60 | ;; | Arrays and records are | 61 | ;; | expanded out. | 62 | ;; | | 63 | ;; | Binders contain spc:base | 64 | ;; | | 65 | ;; | We run algorithms like | 66 | ;; | - void removal | 67 | ;; | - extra let removal | 68 | ;; | - ETC | 69 | ;; +-----------------------------------+ 70 | ;; 71 | 72 | (deftype linear-term () 73 | "A Linear term is a term with no nested terms and is in proper ANF form." 74 | `(or spc:term-type-manipulation 75 | (starting-binders spc:term-type-manipulation) 76 | terms:standalone-ret)) 77 | 78 | (deftype type-aware-term () 79 | "An expanded term is a term where all top level forms have been 80 | expanded into lets or returns" 81 | `(or (starting-binders spc:term-type-manipulation) 82 | terms:standalone-ret)) 83 | 84 | (deftype expanded-term () 85 | "An expanded term is a term where all top level forms have been 86 | expanded into lets or returns, and type coercions have been removed" 87 | `(or (starting-binders spc:term-no-binding) 88 | terms:standalone-ret)) 89 | 90 | (deftype fully-expanded-term () 91 | "A fully expanded term is a `expanded-term' with the records part 92 | removed. Or as we can view it a base term, with the binders added in." 93 | `(or (binders spc:base) 94 | terms:standalone-ret)) 95 | 96 | (deftype starting-binders (&optional contains) 97 | "Terms which deal with binding and naming, the input argument 98 | represents what data may be in the value of the binders." 99 | (declare (ignore contains)) 100 | `(or terms:bind 101 | spc:bind-constraint)) 102 | 103 | (deftype binders (&optional contains) 104 | "Terms which deal with binding and naming, the input argument 105 | represents what data may be in the value of the binders." 106 | `(or (starting-binders ,contains) 107 | terms:multiple-bind)) 108 | 109 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 110 | ;; Linearized types List Aliases 111 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 112 | 113 | (deftype constraint-list () 114 | "A constraint-list is a list of linear-terms" 115 | `(satisfies linear-list)) 116 | 117 | (deftype type-aware-list () 118 | `(satisfies type-aware-list)) 119 | 120 | (deftype expanded-list () 121 | "A constraint-list is a list of expanded-terms" 122 | `(satisfies expanded-list)) 123 | 124 | (deftype fully-expanded-list () 125 | "A constraint-list is a list of fully-expanded-terms" 126 | `(satisfies fully-expanded-list)) 127 | 128 | (defun linear-list (list) 129 | (and (listp list) 130 | (every (lambda (x) (typep x 'linear-term)) list))) 131 | 132 | (defun type-aware-list (list) 133 | (and (listp list) 134 | (every (lambda (x) (typep x 'type-aware-term)) list))) 135 | 136 | (defun expanded-list (list) 137 | (and (listp list) 138 | (every (lambda (x) (typep x 'expanded-term)) list))) 139 | 140 | (defun fully-expanded-list (list) 141 | (and (listp list) 142 | (every (lambda (x) (typep x 'fully-expanded-term)) list))) 143 | -------------------------------------------------------------------------------- /src/typechecker/types.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.typechecker.types) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; Typing Context Structure 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (defclass typing-context () 8 | ((holes :initarg :holes 9 | :accessor holes 10 | :initform nil 11 | :type list ; list (list keywords) 12 | :documentation "Represents the holes to solve. List of keywords") 13 | (hole-info :initarg :hole-info 14 | :accessor hole-info 15 | :initform (closure:allocate) 16 | :type closure:typ ; Closure:typ hole-information 17 | :documentation "Represents information about the holes that we know") 18 | (dependency :initarg :dependency 19 | :accessor dependency 20 | :initform (dependency:allocate) 21 | :type dependency:typ 22 | :documentation "Represents the constraint satisfaction mapping") 23 | (typing-closure :initarg :typing-closure 24 | :accessor typing-closure 25 | :initform (closure:allocate) 26 | :type closure:typ ; Closure:typ type-info 27 | :documentation 28 | "This is the typing closure for terms which we already know")) 29 | (:documentation "This represents the typing context the terms we are 30 | analyzing belong in")) 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | ;;; Function Return Value 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | (deftype typing-result () 36 | "The result of trying to annotate a term" 37 | `(or type-info hole-conditions)) 38 | 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | ;;; Known Type Cache 41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 | 43 | (defstruct type-info 44 | "Type information of a fully realized type." 45 | ;; if we don't know the size quite yet it will be nil 46 | (size nil :type (or fixnum null)) 47 | (type nil :type ir:type-reference)) 48 | 49 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 50 | ;;; Data Types about Holes 51 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | 53 | (defstruct hole-information 54 | (unrefined nil :type hole) 55 | ;; We should redefine term, to be a list of ir:term-no-binding 56 | ;; as we can be solved by various sets of equations. 57 | ;; 58 | ;; What I mean is that if we have `x = some equation', and then 59 | ;; later `y = x' where we solve for `y', then we've solved for `x'. 60 | ;; 61 | ;; Thus the hole-information should be (list equation #) 62 | ;; 63 | ;; And when our dependency closure says we've solved it, try the 64 | ;; list until we get the equation that satisfies the constraint. 65 | (term nil :type list)) 66 | 67 | ;; TODO :: with generics we should make this type a lot more rich and 68 | ;; informative 69 | (deftype hole () 70 | "Represents the format of holes that have yet to be fully realized." 71 | `(or null keyword)) 72 | 73 | (deftype hole-conditions () 74 | "The conditions in which a fialure can happen for " 75 | `(or same-as 76 | (eql :refine-integer) 77 | (eql :refine-array) 78 | depends-on)) 79 | 80 | ;; infer-from 81 | (defstruct same-as 82 | "Represents that the hole is the same as this other variable" 83 | (value (error "fill in the value") :type keyword)) 84 | 85 | (defstruct depends-on 86 | "this represents that the value is tied to the list of values in some 87 | way." 88 | (value nil :type list)) 89 | 90 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 91 | ;;; Data Types about Querying Types 92 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 93 | 94 | (deftype current-information () 95 | "Represents the current knowledge we have on a given type. Thus a 96 | hole, or if the type is known a type reference" 97 | `(or hole ir:type-reference)) 98 | 99 | (deftype lookup-type () 100 | "represents the potential type of a reference. 101 | 102 | _It can either be_ 103 | 1. known 104 | 105 | 2. an unrefined value 106 | - which we represent with a keyword. 107 | - TODO :: Once we update with generics, we should move this to a 108 | `ir:type-reference' 109 | 110 | 3. unknown 111 | - which we represent with null." 112 | `(or type-info hole)) 113 | 114 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 115 | ;;; Data Types about known type primitives 116 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 117 | 118 | (deftype known-primitve-types () 119 | `(or (eql :int) 120 | (eql :bool) 121 | (eql :void) 122 | (eql :array))) 123 | 124 | (deftype known-primitve-functions () 125 | `(or (eql :+) 126 | (eql :*) 127 | (eql :=) 128 | (eql :exp))) 129 | 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | ;;; Operations on Typing Context 132 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 133 | 134 | (defmethod print-object ((obj typing-context) stream) 135 | (print-unreadable-object (obj stream :type t) 136 | (pprint-logical-block (stream nil) 137 | (format stream ":HOLES ~A~_:HOLE-INFO ~A~_:DEPENDENCY ~A~_:TYPING-CLOSURE ~A" 138 | (holes obj) (hole-info obj) (dependency obj) (typing-closure obj))))) 139 | 140 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 141 | ;;; Operations on hole Info 142 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 143 | 144 | (-> add-hole-formula (hole-information alu.spec:term-no-binding) hole-information) 145 | (defun add-hole-formula (hole new-formula) 146 | (make-hole-information :unrefined (hole-information-unrefined hole) 147 | :term (cons new-formula (hole-information-term hole)))) 148 | -------------------------------------------------------------------------------- /test/relocation.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (def-suite alucard.relocation 4 | :description "Test the relocation functionality") 5 | 6 | (in-suite alucard.relocation) 7 | 8 | (defparameter *example-closure* 9 | (closure:allocate 10 | :fi '((:plane . :fi-plane) 11 | (:point . ((:x . :fi-point-x) (:y . :fi-point-y)))))) 12 | 13 | (defparameter *example-bind* 14 | (ir:make-bind :var :hi 15 | :val (ir:make-reference :name :fi))) 16 | 17 | (defparameter *example-bind-app* 18 | (ir:make-bind 19 | :var :hi 20 | :val (ir:make-application :function (ir:make-reference :name :arg-foo) 21 | :arguments '(1 5 6)))) 22 | 23 | (defparameter *example-bind-record* 24 | (ir:make-bind 25 | :var :hi 26 | :val (ir:make-record :name :test 27 | :own (ir:make-reference :name :fi) 28 | :other (ir:make-reference :name :non-exist)))) 29 | 30 | (defparameter *example-bind-lookup-1* 31 | (ir:make-bind 32 | :var :hi 33 | :val (ir:make-record-lookup :record (ir:make-reference :name :fi) 34 | :field :plane))) 35 | (defparameter *example-bind-lookup-2* 36 | (ir:make-bind 37 | :var :hi 38 | :val (ir:make-record-lookup :record (ir:make-reference :name :fi) 39 | :field :point))) 40 | 41 | (test relocate-let-ref 42 | (let ((expected-let-names '(:hi-plane :hi-point-x :hi-point-y)) 43 | (expected-let-resul '(:fi-plane :fi-point-x :fi-point-y)) 44 | (expected-storage '((:PLANE . :HI-PLANE) 45 | (:POINT 46 | (:X . :HI-POINT-X) 47 | (:Y . :HI-POINT-Y)))) 48 | (relocation (relocate:relocate-let *example-bind* *example-closure*))) 49 | (mapcar (lambda (input res bind) 50 | (is (eq input (ir:var bind))) 51 | (is (eq res (ir:name (ir:value bind))))) 52 | expected-let-names 53 | expected-let-resul 54 | (relocate:rel-forms relocation)) 55 | (is (equalp expected-storage (closure:lookup (relocate:rel-closure relocation) 56 | :hi))))) 57 | (test relocate-let-lookup 58 | (let ((expected-let-names '(:hi-point-x :hi-point-y)) 59 | (expected-let-resul '(:fi-point-x :fi-point-y)) 60 | (expected-storage '((:X . :HI-POINT-X) 61 | (:Y . :HI-POINT-Y))) 62 | (relocation-1 (relocate:relocate-let *example-bind-lookup-1* 63 | *example-closure*)) 64 | (relocation-2 (relocate:relocate-let *example-bind-lookup-2* 65 | *example-closure*))) 66 | (mapcar (lambda (input res bind) 67 | (is (eq input (ir:var bind))) 68 | (is (eq res (ir:name (ir:value bind))))) 69 | expected-let-names 70 | expected-let-resul 71 | (relocate:rel-forms relocation-2)) 72 | (is (equalp expected-storage 73 | (closure:lookup (relocate:rel-closure relocation-2) 74 | :hi))) 75 | ;; time for the easier one 76 | (let ((only-form (car (relocate:rel-forms relocation-1)))) 77 | (is (eq :hi 78 | (ir:var only-form))) 79 | (is (eq :fi-plane 80 | (ir:name (ir:value only-form))))))) 81 | 82 | (test relocate-let-record 83 | (let ((expected-let-names '(:hi-own-plane 84 | :hi-own-point-x :hi-own-point-y 85 | :hi-other)) 86 | (expected-let-resul '(:fi-plane 87 | :fi-point-x :fi-point-y 88 | :non-exist)) 89 | (expected-storage '((:OWN . ((:PLANE . :HI-OWN-PLANE) 90 | (:POINT . ((:X . :HI-OWN-POINT-X) 91 | (:Y . :HI-OWN-POINT-Y))))) 92 | (:OTHER . :HI-OTHER))) 93 | (relocation (relocate:relocate-let *example-bind-record* *example-closure*))) 94 | (mapcar (lambda (input res bind) 95 | (is (eq input (ir:var bind))) 96 | (is (eq res (ir:name (ir:value bind))))) 97 | expected-let-names 98 | expected-let-resul 99 | (relocate:rel-forms relocation)) 100 | (is (equalp expected-storage (closure:lookup (relocate:rel-closure relocation) 101 | :hi))))) 102 | 103 | (test relocate-let-app 104 | (let ((expected-binds '(:HI-PLANE-X :HI-PLANE-Y :HI-TIME-X :HI-TIME-Y)) 105 | (expected-storage '((:PLANE 106 | (:X . :HI-PLANE-X) 107 | (:Y . :HI-PLANE-Y)) 108 | (:TIME 109 | (:X . :HI-TIME-X) 110 | (:Y . :HI-TIME-Y)))) 111 | (relocation (relocate:relocate-let *example-bind-app* 112 | *example-closure*))) 113 | 114 | ;; Tests begin here 115 | (is (equalp expected-binds (ir:var (car (relocate:rel-forms relocation))))) 116 | (is (equalp (ir:value *example-bind-app*) 117 | (ir:value (car (relocate:rel-forms relocation)))) 118 | "The function should not change") 119 | (is (equalp expected-storage 120 | (closure:lookup (relocate:rel-closure relocation) 121 | :hi))))) 122 | 123 | (test initial-closure-from-circuit 124 | (let* ((closure (relocate:initial-closure-from-circuit 125 | (storage:lookup-function :arg-circuit-input))) 126 | 127 | (keys (closure:keys closure)) 128 | (expected-storage `((:X . ,(intern (format nil "~A-X" (car keys)) :keyword)) 129 | (:Y . ,(intern (format nil "~A-Y" (car keys)) :keyword))))) 130 | 131 | ;; Tests begin here 132 | (is (= 1 (length keys))) 133 | (is (equalp expected-storage (closure:lookup closure (car keys)))) 134 | (is (equalp nil (closure:lookup closure :root)) 135 | "Root is not a record, we don't ingest it."))) 136 | -------------------------------------------------------------------------------- /src/closure/dependency.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.closure.dependency) 2 | 3 | (defclass typ () 4 | ((direct :initarg :direct 5 | :type closure:typ ; closure:typ (list (list keyword)) 6 | :initform (closure:allocate) 7 | :accessor direct 8 | :documentation "The direct dependency mapping") 9 | (reverse :initarg :reverse 10 | :type closure:typ ; closure:typ (list keyword) 11 | :initform (closure:allocate) 12 | :accessor reverse 13 | :documentation "The reverse dependency mapping") 14 | (cyclic :initarg :cyclic 15 | :type closure:typ ; clsoure:typ (list keyword) 16 | :initform (closure:allocate) 17 | :accessor cyclic 18 | :documentation "Cyclic dependencies") 19 | (solved :initarg :solved 20 | :type list ; list keyword 21 | :initform nil 22 | :accessor solved 23 | :documentation "The currently newly solved values that have 24 | not been cleared, note this list is ordered.")) 25 | (:documentation "The dependency closure that tracks dependencies")) 26 | 27 | (defmethod print-object ((obj typ) stream) 28 | (print-unreadable-object (obj stream :type t) 29 | (pprint-logical-block (stream nil) 30 | (format stream ":DIRECT ~A~_:REVERSE ~A~_:CYCLIC ~A~_:SOLVED ~A" 31 | (direct obj) (reverse obj) (cyclic obj) (solved obj))))) 32 | 33 | (-> get-solved (typ) list) 34 | (defun get-solved (dependency) 35 | (cl:reverse (solved dependency))) 36 | 37 | (-> allocate () typ) 38 | (defun allocate () 39 | (assure typ 40 | (make-instance 'typ))) 41 | 42 | (-> determined-by (typ keyword list) typ) 43 | (defun determined-by (dependency term dependency-list) 44 | "Notes that the given term is entailed by the values in the list." 45 | (let* ((current (closure:lookup (direct dependency) term)) 46 | (new-contents (if current 47 | (cons dependency-list current) 48 | (list dependency-list))) 49 | (typ (handle-cyclic dependency term dependency-list))) 50 | (assure typ 51 | (util:copy-instance typ 52 | :direct (closure:insert (direct typ) term new-contents) 53 | :reverse (add-reverse (reverse typ) term dependency-list))))) 54 | 55 | (-> determine-each-other (typ list) typ) 56 | (defun determine-each-other (dependency keywords) 57 | "Each value is considered to determine each other." 58 | ;; This algorithm can significantly improved 59 | (mvfold (lambda (dep keyword) 60 | ;; O(n²), a set would be nicer 61 | (let ((remove-current (remove-if (lambda (x) (eql x keyword)) keywords))) 62 | (mvfold (lambda (dep keyword-dep) 63 | (determined-by dep keyword (list keyword-dep))) 64 | remove-current 65 | dep))) 66 | keywords 67 | dependency)) 68 | 69 | (-> lookup (typ keyword) list) 70 | (defun lookup (dependency term) 71 | (assure list 72 | (closure:lookup (direct dependency) term))) 73 | 74 | (-> solved-for (typ keyword) typ) 75 | (defun solved-for (dependency term) 76 | (mvfold (lambda (dependency deps-on-term) 77 | (let ((direct (remove-from (direct dependency) deps-on-term term)) 78 | (cyclic (remove-from-if-exists (cyclic dependency) deps-on-term term))) 79 | (util:copy-instance dependency 80 | :direct direct 81 | :cyclic cyclic 82 | :solved 83 | (if (null (closure:lookup direct deps-on-term)) 84 | (adjoin deps-on-term (solved dependency)) 85 | (solved dependency))))) 86 | (closure:lookup (reverse dependency) term) 87 | (util:copy-instance dependency 88 | :reverse (closure:remove (reverse dependency) term) 89 | :cyclic (closure:remove (cyclic dependency) term) 90 | :solved (adjoin term (solved dependency))))) 91 | 92 | (serapeum:-> solved-for* (typ &rest keyword) typ) 93 | (defun solved-for* (dependency &rest keywords) 94 | (mvfold #'solved-for keywords dependency)) 95 | 96 | (-> dump-solved (typ) typ) 97 | (defun dump-solved (dependency) 98 | "Removes the solved values" 99 | (assure typ 100 | (util:copy-instance dependency :solved nil))) 101 | 102 | (-> handle-cyclic (typ keyword list) typ) 103 | (defun handle-cyclic (dependency term depends-on) 104 | (values 105 | (util:copy-instance 106 | dependency 107 | :cyclic (mvfold (lambda (closure dep) 108 | (if (member term (closure:lookup (direct dependency) dep)) 109 | (adjoin-onto (adjoin-onto closure dep term) term dep) 110 | closure)) 111 | depends-on 112 | (cyclic dependency))))) 113 | 114 | (-> add-reverse (closure:typ keyword list) closure:typ) 115 | (defun add-reverse (closure value depends-on) 116 | (mvfold (lambda (closure dependency) 117 | (adjoin-onto closure dependency value)) 118 | depends-on 119 | closure)) 120 | 121 | (-> adjoin-onto (closure:typ keyword t) closure:typ) 122 | (defun adjoin-onto (closure key value) 123 | (closure:insert closure key (adjoin value (closure:lookup closure key)))) 124 | 125 | (-> remove-from (closure:typ keyword keyword) closure:typ) 126 | (defun remove-from (closure key member) 127 | (let ((value (mapcar (lambda (list) 128 | (remove-if (alexandria:curry #'eq member) list)) 129 | (closure:lookup closure key)))) 130 | (if (some #'null value) 131 | (closure:remove closure key) 132 | (closure:insert closure key value)))) 133 | 134 | (-> remove-from-if-exists (closure:typ keyword keyword) closure:typ) 135 | (defun remove-from-if-exists (closure key member) 136 | (if (closure:lookup closure key) 137 | (remove-from closure key member) 138 | closure)) 139 | -------------------------------------------------------------------------------- /src/vampir/spec.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.vampir.spec) 2 | 3 | ;; Here we use the language of vampir to talk about the components 4 | 5 | ;; Adapted form 6 | ;; https://github.com/heliaxdev/ark-plonk/blob/plonk-ir/plonk-ir/src/plonk_ir.pest 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Sum Type Declarations 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (deftype statement () 13 | `(or alias pub constraint)) 14 | 15 | (deftype constraint () 16 | `(or application bind equality expression)) 17 | 18 | ;; called base in the file 19 | ;; Values are called over a normal form!?!?!? 20 | (deftype expression () 21 | `(or infix application normal-form tuple)) 22 | 23 | (deftype normal-form () 24 | `(or wire constant)) 25 | 26 | (deftype primitive () 27 | `(or (eql :+) (eql :-) (eql :*) (eql :^))) 28 | 29 | (deftype constraint-list () 30 | `(satisfies constraint-list)) 31 | 32 | (deftype normal-form-list () 33 | `(satisfies normal-form-list)) 34 | 35 | (defun constraint-list (list) 36 | (and (listp list) 37 | (every (lambda (x) (typep x 'constraint)) list))) 38 | 39 | (defun normal-form-list (list) 40 | (and (listp list) 41 | (every (lambda (x) (typep x 'normal-form)) list))) 42 | 43 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 44 | ;; Statement Product Types 45 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 46 | 47 | (defclass alias () 48 | ((name :initarg :name 49 | :type keyword 50 | :accessor name 51 | :documentation "Name of the alias gate") 52 | (inputs :initarg :inputs 53 | :type list 54 | :accessor inputs 55 | :documentation "the arguments to the circuit") 56 | ;; we should move this to an expression instead 57 | ;; See Issue #38 comment 1 on why. 58 | ;; (outputs :initarg :outputs 59 | ;; :type list 60 | ;; :accessor outputs 61 | ;; :documentation "The return wires of the circuit") 62 | ;; TODO :: layout types 63 | (body :initarg :body 64 | :accessor body 65 | :type constraint-list)) 66 | (:documentation "An alias gate in vamp-ir")) 67 | 68 | (defclass pub () 69 | ((wires :initarg :wires 70 | :type list 71 | :accessor wires))) 72 | 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | ;; Expression Product Types 75 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 76 | 77 | (defclass infix () 78 | ((op :initarg :op 79 | :accessor op 80 | :type primitive 81 | :documentation "the alias we are calling") 82 | (lhs :initarg :lhs 83 | :accessor lhs 84 | :type expression 85 | :documentation "the argument to the left of the op") 86 | (rhs :initarg :rhs 87 | :accessor rhs 88 | :type expression 89 | :documentation "the argument to the right of the op"))) 90 | 91 | (defclass application () 92 | ((func :initarg :function 93 | :accessor func 94 | :type keyword 95 | :documentation "the alias we are calling") 96 | (arguments :initarg :arguments 97 | ;; I assume list of expressions? 98 | :type cons 99 | :accessor arguments 100 | :documentation "The arguments in which the gate is called upon"))) 101 | 102 | (defclass bind () 103 | ((names :initarg :names 104 | :accessor names 105 | :type normal-form-list) 106 | (value :initarg :value 107 | :accessor value 108 | ;; can't be a constant however! 109 | :type expression))) 110 | 111 | (defclass equality () 112 | ((lhs :initarg :lhs 113 | :accessor lhs 114 | :type expression 115 | :documentation "the argument to the left of the =") 116 | (rhs :initarg :rhs 117 | :accessor rhs 118 | :type expression 119 | :documentation "the argument to the rigth of the ="))) 120 | 121 | (defclass tuple () 122 | ((wires :initarg :wires 123 | :type list 124 | :accessor wires))) 125 | 126 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 127 | ;; Normal Form Product Types 128 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 129 | 130 | (defclass wire () 131 | ((var :initarg :var 132 | :accessor var 133 | :type keyword)) 134 | (:documentation "A reference in vamp-ir")) 135 | 136 | (defclass constant () 137 | ((const :initarg :const 138 | :accessor const))) 139 | 140 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 141 | ;; Alias 142 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 143 | 144 | (defun make-alias (&key name inputs body) 145 | (make-instance 'alias :name name :inputs inputs :body body)) 146 | 147 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 148 | ;; Pub 149 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 150 | 151 | (defun make-pub (&key wires) 152 | (make-instance 'pub :wires wires)) 153 | 154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 155 | ;; Infix 156 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 | 158 | (defun make-infix (&key lhs op rhs) 159 | (make-instance 'infix :lhs lhs :op op :rhs rhs)) 160 | 161 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 162 | ;; Application 163 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 164 | 165 | (defun make-application (&key func arguments) 166 | (make-instance 'application :function func :arguments arguments)) 167 | 168 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 169 | ;; Bind 170 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 171 | 172 | (defun make-bind (&key names value) 173 | (make-instance 'bind :names names :value value)) 174 | 175 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 176 | ;; Equality 177 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 178 | 179 | (defun make-equality (&key lhs rhs) 180 | (make-instance 'equality :lhs lhs :rhs rhs)) 181 | 182 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 183 | ;; Wire 184 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 185 | 186 | (defun make-wire (&key var) 187 | (make-instance 'wire :var var)) 188 | 189 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 190 | ;; Constant 191 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 192 | 193 | (defun make-constant (&key const) 194 | (make-instance 'constant :const const)) 195 | 196 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 197 | ;; Tuples 198 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 199 | 200 | (defun make-tuples (&key wires) 201 | (make-instance 'tuple :wires wires)) 202 | -------------------------------------------------------------------------------- /test/step.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu-test) 2 | 3 | (def-suite alucard.step 4 | :description "Testing the stepper") 5 | 6 | (in-suite alucard.step) 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;; Definitions 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (step.def:defun base () 13 | (car (list (stack:get)))) 14 | 15 | (step.def:defun calling-base () 16 | (if (listp (stack:stack (base))) 17 | (base))) 18 | 19 | (defmacro expansion-test (x) 20 | `(progn ,x)) 21 | 22 | (step.def:defun expansion-call () 23 | (expansion-test (stack:get))) 24 | 25 | (step.def:defun local-expansion-test (x) 26 | (flet ((expansion-test (x) (list x (stack:get)))) 27 | (expansion-test x))) 28 | 29 | (step.def:defun local-expansion-test-labels (x) 30 | (labels ((expansion-test (x) (list x (stack:get))) 31 | (faz (x) (expansion-test x))) 32 | (faz x))) 33 | 34 | (step.def:defun lets-explore (x) 35 | (funcall (lambda (x) (+ x 5)) x)) 36 | 37 | (step.def:defun macro-let-test () 38 | (macrolet ((lets-explore (x) `(progn ,x))) 39 | (lets-explore (stack:get)))) 40 | 41 | ;; just checking all these run fine, with no issues 42 | (step.def:defun alu-primitives (x y) 43 | (declare (ignore y)) 44 | 45 | (prld:def ((prld:with-constraint (b2 b3) 46 | (prld:= x (prld:+ b2 b3)))) 47 | (prld:with-constraint (b2 b3) 48 | (prld:= x (prld:+ b2 b3))) 49 | 50 | (alu:array 512 (int 1)) 51 | 52 | (def ((bit-array (aluser::reshape x 512 :type (int 1)))) 53 | (prld:get bit-array x)) 54 | 55 | (prld:= (prld:+ (prld:exp x 3) 56 | (prld:* 3 (prld:exp x 2)) 57 | (prld:* 2 x) 58 | 4) 59 | 0) 60 | 61 | (prld:def ((bar (prld:to-array 36))) 62 | (prld:+ (prld:check 5 (int 32)) 63 | (prld:get bar 0))) 64 | 65 | (def ((with-constraint (y z) 66 | (prld:= x (prld:+ (prld:* y 10) z)))) 67 | z))) 68 | 69 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 70 | ;; Doing Examples from the wiki 71 | ;; to see if our code walks properly 72 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 73 | 74 | (step.def:defun prince-of-clarity (w) 75 | "Take a cons of two lists and make a list of conses. 76 | Think of this function as being like a zipper." 77 | (do ((y (car w) (cdr y)) 78 | (z (cdr w) (cdr z)) 79 | (x '() (cons (cons (car y) (car z)) x))) 80 | ((null y) x) 81 | (when (null z) 82 | (cerror "Will self-pair extraneous items" 83 | "Mismatch - gleep! ~S" y) 84 | (setq z y)))) 85 | 86 | (step.def:defun king-of-confusion (w) 87 | "Take a cons of two lists and make a list of conses. 88 | Think of this function as being like a zipper." 89 | (prog (x y z) ;Initialize x, y, z to NIL 90 | (setq y (car w) z (cdr w)) 91 | loop 92 | (cond ((null y) (return x)) 93 | ((null z) (go err))) 94 | rejoin 95 | (setq x (cons (cons (car y) (car z)) x)) 96 | (setq y (cdr y) z (cdr z)) 97 | (go loop) 98 | err 99 | (cerror "Will self-pair extraneous items" 100 | "Mismatch - gleep! ~S" y) 101 | (setq z y) 102 | (go rejoin))) 103 | 104 | (step.def:defun throwing-test () 105 | (catch 'foo 106 | (format t "The inner catch returns ~s.~%" 107 | (catch 'foo 108 | (unwind-protect (throw 'foo :first-throw) 109 | (throw 'foo :second-throw)))) 110 | (the keyword :outer-catch))) 111 | 112 | (step.def:defun rest-test () 113 | (list 114 | (= ((lambda (x) x) 3) 3) 115 | (equalp (multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5)) 116 | '(1 / 2 3 / / 2 0.5)) 117 | (let* ((temp '(1 2 3))) 118 | (equalp 1 119 | (multiple-value-prog1 120 | (values-list temp) 121 | (setq temp nil) 122 | (values-list temp)))) 123 | (equalp '(3 4) 124 | (let ((x 3)) 125 | (progv '(x) '(4) 126 | (list x (symbol-value 'x))))))) 127 | 128 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 129 | ;;; Tests 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | 132 | (test nesting-respected 133 | (let ((base (calling-base))) 134 | (is (= (length (stack:stack (stack:current-section base))) 3) 135 | "The current get should be in the parent!") 136 | (is (= (length (stack:stack (stack:current-section 137 | (stack:cdr-current-section base)))) 138 | 2) 139 | "calling a traced function should have the parents call put in 140 | there as well!"))) 141 | 142 | (test macro-expected 143 | (is (equalp (stack:stack (stack:current-section (expansion-call))) 144 | '((STACK:GET) (PROGN (STACK:GET)) (EXPANSION-TEST (STACK:GET)))) 145 | "The macro should be recorded wholesale along with it's expansion") 146 | (is 147 | (equalp (stack:stack (stack:current-section (cadr (local-expansion-test 5)))) 148 | `((STACK:GET) 149 | (LIST X (STACK:GET)) 150 | (EXPANSION-TEST X) 151 | (FLET ((EXPANSION-TEST (X) (LIST X (STACK:GET)))) (EXPANSION-TEST X)))) 152 | "Fletting beats macros!") 153 | (is 154 | (equalp (stack:stack (stack:current-section 155 | (cadr (local-expansion-test-labels 3)))) 156 | `((STACK:GET) 157 | (LIST X (STACK:GET)) 158 | (EXPANSION-TEST X) 159 | (FAZ X) 160 | (LABELS ((EXPANSION-TEST (X) (LIST X (STACK:GET))) 161 | (FAZ (X) (EXPANSION-TEST X))) 162 | (FAZ X)))) 163 | "Labels removes the recursive macro calls") 164 | (is (= (length (stack:stack (stack:current-section (macro-let-test)))) 165 | 4) 166 | "Macro expansion from a macrolet works as expected")) 167 | 168 | (test instrumentation-does-not-interfere 169 | (is (equalp (king-of-confusion (cons (list 1 2 3) 170 | (list 4 6 7))) 171 | '((3 . 7) (2 . 6) (1 . 4))) 172 | "Instrumenting simply adds debugging information does not change semantics") 173 | (is (equalp (prince-of-clarity (cons (list 1 2 3) 174 | (list 4 6 7))) 175 | '((3 . 7) (2 . 6) (1 . 4))) 176 | "Instrumenting simply adds debugging information does not change semantics") 177 | (is (equalp (lets-explore 10) 15) 178 | "lambda should not loop forever") 179 | (is (stack:emptyp (stack:get)) 180 | "Cleanup should be had after all these calls!") 181 | (finishes (alu-primitives 3 5)) 182 | (is (eql (throwing-test) :outer-catch)) 183 | (is (every #'identity (rest-test)))) 184 | -------------------------------------------------------------------------------- /src/pass/anf.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.pass.anf) 2 | 3 | ;;; After the let change, I'm not sure this code is correct, hard to 4 | ;;; even test, as our pass already puts it into anf form! 5 | 6 | (-> normalize-expression (spc:expression) spc:expression) 7 | (defun normalize-expression (expression) 8 | "Takes a potentially nested term, and flattens it with let bindings" 9 | (normalize expression #'identity)) 10 | 11 | (-> normalp (spc:expression) boolean) 12 | (defun normalp (expr) 13 | (typep expr 'spc:term-normal-form)) 14 | 15 | (-> normalize 16 | (spc:expression (-> (spc:expression) spc:expression)) spc:expression) 17 | (defun normalize (term constructor) 18 | "normalize works by taking a term, deciding if it needs to be let 19 | abstracted. if so, then we generate a let binding over the constructor 20 | calling it with the ref. Thus: 21 | 22 | (normalize 3 g) = 23 | (g 3) 24 | (normalize (h x y) g) = 25 | (make-let :var (gen-sym ...) :val (h x y) :body (g gen-sym)) 26 | 27 | Note that for any term which can nest, we build up a continuation that 28 | will evaluate to this let buildup." 29 | (match-of spc:expression term 30 | ;; for terms which are just references or numbers we can 31 | ;; just call the constructor, and end the algorithm 32 | ((spc:number numb) (funcall constructor numb)) 33 | ((spc:reference) (funcall constructor term)) 34 | ;; For nodes which are not in normal form, recurse building 35 | ;; up the let chain 36 | ((spc:let-node spc:value spc:var) 37 | (normalize spc:value 38 | (lambda (new-val) 39 | (funcall constructor 40 | (spc:copy-meta term 41 | (spc:make-let :var spc:var 42 | :val new-val)))))) 43 | ((spc:application spc:name spc:arguments) 44 | (normalize-bind 45 | spc:name 46 | (lambda (func-name) 47 | (normalize-bind* 48 | spc:arguments 49 | (lambda (args) 50 | (funcall constructor 51 | (spc:copy-meta term 52 | (spc:make-application :function func-name 53 | :arguments args)))))))) 54 | ((spc:record spc:name spc:contents spc:order) 55 | ;; probably the hardest transform just due to hash table format 56 | ;; schenans. Note that an alist is like the following 57 | ;; ((:key1 . term1) (:key2 . term2)) 58 | ;; spc:name is a keyword so no need to traverse 59 | (let* ((alist-contents (sycamore:tree-map-alist spc:contents)) 60 | (keys (mapcar #'car alist-contents)) 61 | (values (mapcar #'cdr alist-contents))) 62 | (normalize-bind* 63 | values 64 | (lambda (value-refs) 65 | (funcall constructor 66 | (spc:copy-meta 67 | term 68 | (make-instance 'spc:record 69 | :name spc:name 70 | :order spc:order 71 | :contents (sycamore:alist-tree-map 72 | ;; remake our alist 73 | (mapcar #'cons keys value-refs) 74 | #'util:hash-compare)))))))) 75 | ((spc:record-lookup spc:record spc:field) 76 | ;; field is a keyword, thus we are fine with it 77 | (normalize-bind spc:record 78 | (lambda (rec-ref) 79 | (funcall constructor 80 | (spc:copy-meta 81 | term 82 | (spc:make-record-lookup :record rec-ref 83 | :field spc:field)))))) 84 | ((spc:bind-constraint spc:var spc:value) 85 | (normalize spc:value 86 | (lambda (constraint) 87 | (funcall constructor 88 | (spc:copy-meta 89 | term 90 | (spc:make-bind-constraint :var spc:var 91 | :value constraint)))))) 92 | ;; we get a bad exhaustive message due to number, but it will warn 93 | ;; us, if they aren't the same none the less! 94 | ((cons _ _) 95 | (let* ((body (mapcar (lambda (ter) (normalize ter #'identity)) 96 | term)) 97 | (res (mvfoldr #'combine-expression body nil))) 98 | (funcall constructor res))) 99 | ;; here we stick the types that we want to do the catch all 100 | ;; logic. Good to be explicit here 101 | ((or (spc:type-coerce) (spc:type-check) 102 | (spc:array-lookup) (spc:array-set) (spc:array-allocate) (spc:from-data)) 103 | (normalize-bind* (spc:direct-slot-values term) 104 | (lambda (args) 105 | (funcall constructor 106 | (spc:update-from-alist 107 | term 108 | (mapcar #'cons 109 | (spc:direct-slot-keywords term) 110 | args)))))))) 111 | 112 | ;; replace expression with terms here!? 113 | ;; this function was taken from 114 | ;; https://matt.might.net/articles/a-normalization/ 115 | (-> normalize-bind 116 | (spc:expression (-> (spc:expression) spc:expression)) spc:expression) 117 | (defun normalize-bind (expr cont) 118 | "normalize-bind normalizes the given expression, creating an unique 119 | let binding if the result of normalization is itself not in normal form" 120 | (if (listp expr) 121 | (normalize-bind* expr cont) 122 | (normalize expr 123 | (lambda (expr) 124 | (if (normalp expr) 125 | (funcall cont expr) 126 | (let ((var (util:symbol-to-keyword (gensym "&G")))) 127 | (combine-expression 128 | (spc:copy-meta expr 129 | (spc:make-let 130 | :var var 131 | :val expr)) 132 | (funcall cont (spc:copy-meta 133 | expr 134 | (spc:make-reference :name var)))))))))) 135 | 136 | (-> normalize-bind* (list (-> (list) spc:expression)) spc:expression) 137 | (defun normalize-bind* (list cont) 138 | ;; can't foldr here, as it turns out, we need access to the recursive calls ☹ 139 | (if (null list) 140 | (funcall cont nil) 141 | (normalize-bind 142 | (car list) 143 | (lambda (ref-car) 144 | ;; induction! 145 | (normalize-bind* (cdr list) 146 | (lambda (ref-cdr) 147 | (funcall cont (cons ref-car ref-cdr)))))))) 148 | 149 | (-> combine-expression (t (or null spc:expression)) spc:expression) 150 | (defun combine-expression (expr1 expr2) 151 | (dispatch-case ((expr1 spc:expression) 152 | (expr2 (or null spc:expression))) 153 | ((cons cons) (append expr1 expr2)) 154 | ((spc:term spc:term) (list expr1 expr2)) 155 | ((cons spc:term) (append expr1 (list expr2))) 156 | ((spc:term cons) (cons expr1 expr2)) 157 | ((cons null) expr1) 158 | ((spc:term null) (list expr1)))) 159 | -------------------------------------------------------------------------------- /alu.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :alu 2 | :depends-on (:trivia :alexandria :sycamore :serapeum :closer-mop :command-line-arguments 3 | (:version "asdf" "3.3.5") 4 | :swank :slynk 5 | :cl-environments 6 | :verbose) 7 | :version "0.0.0" 8 | :description "Powering Vamp-IR with the power of the original lineage" 9 | :author "Mariari" 10 | :license "MIT" 11 | :pathname "src/" 12 | :build-pathname "../build/alu.image" 13 | :entry-point "alu::main" 14 | :build-operation ;; #+(or ecl ccl) 15 | "program-op" 16 | ;; #-(or ecl ccl) "image-op" 17 | :components 18 | ((:module util 19 | :serial t 20 | :description "Internal utility functions" 21 | :components ((:file "package") 22 | (:file "bit") 23 | (:file "utils"))) 24 | (:module reference 25 | :serial t 26 | :description "Defines a mutable pass by reference module" 27 | :depends-on () 28 | :components ((:file "package") 29 | (:file "ref"))) 30 | (:module stack 31 | :serial t 32 | :description "Defines a simple stack data structure designed for stack traces" 33 | :depends-on ("reference") 34 | :components ((:file "package") 35 | (:file "stack"))) 36 | (:module closure 37 | :serial t 38 | :description "Closure data type and utilities" 39 | :depends-on ("util") 40 | :pathname #P"closure/" 41 | :components ((:file "package") 42 | (:file "closure") 43 | (:file "dependency"))) 44 | (:module specification 45 | :serial t 46 | :description "Internal Alucard Specification" 47 | :depends-on ("util" "closure" "stack") 48 | :pathname #P"spec/" 49 | :components ((:file "package") 50 | (:file "data-traversal") 51 | (:file "meta") 52 | (:file "term") 53 | (:file "type") 54 | (:file "global") 55 | (:file "storage") 56 | (:file "type-op") 57 | (:file "term-op") 58 | (:file "emit"))) 59 | (:module vampir 60 | :serial t 61 | :description "The Vampir Extraction Module" 62 | :components ((:file "package") 63 | (:file "spec") 64 | (:file "vampir"))) 65 | (:module intermediate-representation 66 | :serial t 67 | :description "The various IR's of the Alucard compiler" 68 | :depends-on ("util" "specification") 69 | :pathname #p"intermediate/" 70 | :components ((:file "package") 71 | (:file "primitive-global") 72 | (:file "new-terms") 73 | (:file "spec"))) 74 | (:module typechecker 75 | :serial t 76 | :description "The type checker of the Alucard compiler" 77 | :depends-on ("util" "closure" "intermediate-representation" log) 78 | :components ((:file "package") 79 | (:file "types") 80 | (:file "size") 81 | (:file "unifier") 82 | (:file "typecheck") 83 | (:file "intro"))) 84 | (:module pass 85 | :serial t 86 | :depends-on ("intermediate-representation" 87 | "closure" 88 | "vampir" 89 | "util" 90 | typechecker 91 | log) 92 | :description "Alucard Passes" 93 | :components ((:file "package") 94 | (:file "evaluate-body") 95 | (:file "expand") 96 | (:file "relocation") 97 | (:file "anf") 98 | (:file "extract") 99 | (:file "redundant-let") 100 | (:file "pack") 101 | (:file "pass") 102 | (:file "array") 103 | (:file "dependencies") 104 | (:file "pipeline"))) 105 | (:module stepper 106 | :serial t 107 | ;; we need symbols like `alu:def' in scope, in the future we 108 | ;; should remove the dependency on package and have a way of 109 | ;; extending our stepper with new primitives, and ways of stepping 110 | ;; through it. So we can instrument our specials in (:file alu) 111 | ;; instead. 112 | :depends-on (package stack) 113 | :description "Provides a syntax stepper that can step through the 114 | syntax of common lisp and allow instrumenting syntax such that a 115 | stack can be implemented." 116 | :components ((:file "package") 117 | (:file "stepper") 118 | (:file "define"))) 119 | (:module log 120 | :serial t 121 | :depends-on (specification) 122 | :components ((:file "package") 123 | (:file "log"))) 124 | ;; only folder without a package 125 | (:module prelude 126 | :serial t 127 | :description "Alucard Prelude" 128 | :depends-on (alu pass) 129 | :pathname #P"../alu/" 130 | :components ((:file "package") 131 | (:file "prelude"))) 132 | (:file "package" :depends-on ("specification")) 133 | (:file "alu" :depends-on (package stepper)) 134 | (:file "../app/main" :depends-on ("alu" "prelude"))) 135 | :in-order-to ((asdf:test-op (asdf:test-op :alu/test)))) 136 | 137 | (asdf:defsystem :alu/test 138 | :depends-on (:alu :fiveam) 139 | :description "Testing alu" 140 | :pathname "test/" 141 | :serial t 142 | :components 143 | ((:file "package") 144 | ;; we setup our table with global-examples 145 | (:file "global-examples") 146 | (:file "alu") 147 | (:file "spec") 148 | (:file "anf") 149 | (:file "expand") 150 | (:file "relocation") 151 | (:file "evaluate-body") 152 | (:file "dependencies") 153 | (:file "typecheck") 154 | (:file "packing") 155 | (:file "pass") 156 | (:file "vampir") 157 | (:file "stack") 158 | (:file "step") 159 | (:file "run-tests")) 160 | :perform (asdf:test-op (o s) 161 | (uiop:symbol-call :alu-test :run-tests))) 162 | 163 | ;; Big TODO, figure out how to get good docs for Our project! 164 | (asdf:defsystem :alu/documentation 165 | :depends-on (:fiveam 166 | :swank :slynk 167 | :staple 168 | :staple-server :asdf-package-system 169 | :staple-restructured-text) 170 | :description "Documenting alu" 171 | :pathname "test/" 172 | :serial t 173 | :components 174 | () 175 | :perform (asdf:test-op (o s) 176 | (uiop:symbol-call :alu-test :run-tests))) 177 | 178 | ;; #-clpm-client 179 | (defun activate-project () 180 | "Activates the projects clmpfile after `clpm-client' is loaded as the 181 | default project. Note that the repl must be in the ALU directory for 182 | the fileplath to work!" 183 | (uiop:symbol-call :clpm-client '#:activate-context (truename "clpmfile") 184 | :activate-asdf-integration t)) 185 | 186 | (uiop/image:register-image-restore-hook 187 | (lambda () 188 | (uiop:symbol-call :verbose 'restart-global-controller) 189 | (setf *package* (find-package :aluser)) 190 | (setf *print-pretty* t)) 191 | nil) 192 | 193 | (uiop/image:register-image-dump-hook 194 | (lambda () 195 | (uiop:symbol-call :verbose 'remove-global-controller)) 196 | nil) 197 | 198 | #+sb-core-compression 199 | (defmethod asdf:perform ((o asdf:image-op) (c asdf:system)) 200 | (uiop:dump-image (asdf:output-file o c) :executable t :compression t)) 201 | 202 | (defun make-system () 203 | (handler-case (asdf:load-system :alu) 204 | (error (c) 205 | (declare (ignorable c)) 206 | (ql:quickload :alu))) 207 | (asdf:make :alu)) 208 | -------------------------------------------------------------------------------- /src/pass/pack.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.pass.pack) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Packing Operations 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (-> op 8 | (check:typing-context 9 | check:type-info 10 | ir:term-no-binding 11 | &rest ir:term-normal-form) 12 | (values check:typing-context ir:expanded-list)) 13 | (defun op (closure type-format term &rest data) 14 | "Packs the given data into the format specified by the 15 | `type-format'. the `term' is used solely for meta information 16 | propagation" 17 | (let ((ref (check:type-info-type type-format))) 18 | (cond ((type-op:array-reference? ref) 19 | (apply #'array closure type-format term data)) 20 | ((type-op:record-reference? ref) 21 | (apply #'record closure type-format term data)) 22 | (t 23 | (error "Reference of type ~A can not be packed" ref))))) 24 | 25 | (-> array 26 | (check:typing-context 27 | check:type-info 28 | ir:term-no-binding 29 | &rest 30 | ir:term-normal-form) 31 | (values check:typing-context ir:expanded-list)) 32 | (defun array (closure type-format term &rest data) 33 | (let ((length (ir:array-type-len (check:type-info-type type-format))) 34 | (data-size (array-data-size type-format))) 35 | (pipeline:type-check-expression 36 | ;; We can pack the data by adding all the values together in a 37 | ;; smart way. Namely if we bitshift by the length of the type, 38 | ;; then there can be no clash, and we can just make our 39 | ;; constraints `util:sequence-to-number' is this same algorithm 40 | ;; except for CL data. 41 | ;; 42 | ;; We get back an expanded list from this, with the last let, 43 | ;; being the value that contains our addition. 44 | ;; 45 | ;; TODO :: Add type coercing on the element, as we will want a 46 | ;; bignum out of the computation. This only matters when 47 | ;; we generate code mod n 48 | (ir:copy-meta 49 | term 50 | (apply #'term-op:add 51 | (mapcar (lambda (element position) 52 | (term-op:times element 53 | (expt 2 (* position data-size)))) 54 | data 55 | (alexandria:iota length)))) 56 | closure))) 57 | 58 | (-> final-ref-from-op (ir:expanded-list) ir:reference) 59 | (defun final-ref-from-op (result-terms) 60 | (ir:make-reference :name 61 | (ir:var (car (last result-terms))))) 62 | 63 | 64 | (-> record 65 | (check:typing-context check:type-info ir:record-lookup ir:term-normal-form) 66 | (values check:typing-context ir:expanded-list)) 67 | (defun record (closure type-format term data) 68 | type-format closure data term 69 | (error "not implemented")) 70 | 71 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 72 | ;; Indexing Operations 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | 75 | (-> lookup-at 76 | (check:typing-context 77 | check:type-info 78 | ir:term-no-binding 79 | (or ir:term-normal-form keyword) 80 | ir:term-normal-form) 81 | (values check:typing-context ir:expanded-list)) 82 | (defun lookup-at (context type term to-find data) 83 | (let ((ref (check:type-info-type type))) 84 | (cond ((and (type-op:array-reference? ref) 85 | (not (keywordp to-find))) 86 | (array-lookup context type term to-find data)) 87 | ((type-op:record-reference? ref) 88 | (error "not implemented")) 89 | (t 90 | (error "Reference of type ~A can not be packed" ref))))) 91 | 92 | 93 | (-> array-lookup 94 | (check:typing-context 95 | check:type-info 96 | ir:array-lookup 97 | ir:term-normal-form 98 | ir:term-normal-form) 99 | (values check:typing-context ir:expanded-list)) 100 | (defun array-lookup (closure type term index data) 101 | (flet ((int (data) 102 | (term-op:coerce :int data)) 103 | (ref (keyword) 104 | (ir:make-reference :name keyword)) 105 | (+ (left right) 106 | (term-op:add left right)) 107 | (× (left right) 108 | (term-op:times left right))) 109 | (let ((size (array-data-size type)) 110 | (target-type (ir:array-type-content (check:type-info-type type)))) 111 | (check:with-intro (closure unused-array unused-mod 112 | smaller-array lookup-answer) 113 | closure 114 | ;; The equation here is trying to do the following equation 115 | ;; 116 | ;; want : array[index] 117 | ;; 118 | ;; how to compute : 119 | ;; 120 | ;; array = 2 ^ (index * size) * smaller-array + unused-mod 121 | ;; 122 | ;; smaller-array = 2 ^ size * unused-arr + answer 123 | ;; 124 | ;; answer 125 | ;; 126 | ;; However we have to coerce: 127 | ;; - answer to the proper type. 128 | ;; - index to be a bignum 129 | ;; - array to be a bignum 130 | ;; 131 | ;; Thus we arrive at 132 | ;; (def ((with-constraint (smal unused-mod unused-arr answer) 133 | ;; (= data (+ (* smal (expt 2 (* index size))) unused-mod)) 134 | ;; (= smal (+ (* unused-arr (expt 2 index)) answer)))) 135 | ;; (coerce answer type) 136 | ;; 137 | ;; However we have to use more verbose names and coerce by hand. 138 | ;; 139 | ;; TODO :: Ι was told that this creates too many solutions, 140 | ;; so we have to note a range check on the size of the 141 | ;; elements to properly constrain the values. Thus we 142 | ;; need to do 0 <= mod value <= 2 ^ value 143 | (pipeline:type-check-expression 144 | (ir:copy-meta 145 | term 146 | (ir:make-bind-constraint 147 | :var (list unused-array unused-mod smaller-array lookup-answer) 148 | :value 149 | (list 150 | (term-op:= (int data) 151 | (+ (× (term-op:exp 2 (term-op:times size (int index))) 152 | (ref smaller-array)) 153 | (ref unused-mod))) 154 | ;; range check 155 | (term-op:= (ref smaller-array) 156 | (+ (× (term-op:exp 2 size) 157 | (ref unused-array)) 158 | (ref lookup-answer))) 159 | (ir:copy-meta term 160 | (ir:make-type-coerce :typ target-type 161 | :value (ref lookup-answer)))))) 162 | closure))))) 163 | 164 | (-> array-lookup-final-ref (ir:expanded-list) ir:reference) 165 | (defun array-lookup-final-ref (result-term) 166 | (ir:make-reference :name (ir:var 167 | (car (last (ir:value (car result-term))))))) 168 | 169 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 170 | ;; Full Unpacking logic 171 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 172 | 173 | (-> unpack (check:type-info ir:term-normal-form) ir:expanded-term) 174 | (defun unpack (type data) 175 | type data 176 | (error "not implemented")) 177 | 178 | 179 | (-> array-data-size (check:type-info) fixnum) 180 | (defun array-data-size (format) 181 | (let* ((array-info (check:type-info-type format)) 182 | (length (ir:array-type-len array-info))) 183 | (/ (check:type-info-size format) 184 | length))) 185 | -------------------------------------------------------------------------------- /src/spec/global.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.spec) 2 | 3 | (deftype function-type () 4 | "The type we store in the top level function storage" 5 | `(or primitive circuit)) 6 | 7 | (deftype type-storage () 8 | "The type we store in the top level type storage" 9 | `(or primitive type-declaration)) 10 | 11 | ;; Augment primitive to have return type as well! 12 | (defmethod return-type ((primitive primitive)) 13 | ;; replace with an exhaustive match! 14 | (case (name primitive) 15 | ;; we know these return a field/int 16 | ((:+ :* :- :/ :exp) (make-type-reference :name :int)) 17 | ;; default to int 18 | (t (make-type-reference :name :int)))) 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;; Function Type Storage Type ;; 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | (defclass circuit () 25 | ((name :initarg :name 26 | :type keyword 27 | :accessor name 28 | :documentation "Name of the circuit") 29 | ;; a list of constraints 30 | (arguments :initarg :arguments 31 | :type list 32 | :accessor arguments 33 | :documentation "Arguments for the circuit, saved in a 34 | a list of `constraint'") 35 | (return-type :initarg :return-type 36 | :type (or type-reference null) 37 | :accessor return-type 38 | :documentation "The return output of a given circuit") 39 | (body :initarg :body 40 | :accessor body 41 | :documentation "The frozen circuit literal") 42 | (execution-body :initarg :exec 43 | :accessor exec 44 | :documentation "The circuit logic"))) 45 | 46 | (deftype privacy () 47 | `(or (eql :private) 48 | (eql :public))) 49 | 50 | (defclass constraint () 51 | ((name :initarg :name 52 | :initform :name 53 | :type keyword 54 | :accessor name 55 | :documentation "The name of the constraint") 56 | (privacy :initarg :privacy 57 | :initform :private 58 | :type privacy 59 | :accessor privacy 60 | :documentation "Is the constraint public or private?") 61 | (type :initarg :type 62 | :type type-reference 63 | :accessor typ 64 | :documentation "The type of the constraint"))) 65 | 66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 | ;; Alu Type Storage Type ;; 68 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 69 | 70 | (defclass type-declaration () 71 | ((name :initarg :name 72 | :type keyword 73 | :accessor name 74 | :documentation "The name of the Type") 75 | ;; currently unused 76 | (generics :initarg :generics 77 | :type list 78 | :accessor generics 79 | :documentation "Any extra generic argumentation that the 80 | type can take (primitives take an extra integer, we may with to propagate)") 81 | (options :initarg :options 82 | :initform (sycamore:make-tree-map #'util:hash-compare) 83 | :type sycamore:tree-map 84 | :accessor options 85 | :documentation "The Options for the declaration") 86 | (declaration :initarg :decl 87 | :type type-format 88 | :accessor decl 89 | :documentation "The data declaration")) 90 | (:documentation "Type declaration in the Alu language")) 91 | 92 | (deftype type-format () 93 | "this is the choice of the format the type declaration can be" 94 | `(or record-decl sum-decl)) 95 | 96 | (defclass record-decl () 97 | ((contents :initarg :contents 98 | :initform (sycamore:make-tree-map #'util:hash-compare) 99 | :type sycamore:tree-map 100 | :accessor contents 101 | :documentation "Holding fields that are declared along with their type") 102 | (order :initarg :order 103 | :initform nil 104 | :type list 105 | :accessor order 106 | :documentation "For keeping a consistent order of fields between implementations")) 107 | (:documentation "Record declaration")) 108 | 109 | (defclass sum-decl () 110 | () 111 | (:documentation "Sum type declaration")) 112 | 113 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 114 | ;; Function Type Storage Functions ;; 115 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 116 | 117 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 118 | ;; Circuit Functionality 119 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 120 | 121 | 122 | (defmethod print-object ((obj circuit) stream) 123 | (with-accessors ((name name) (ret return-type) (bod body) (arg arguments)) obj 124 | (format stream "Circuit ~A~{ ~A~^~} =~%~A : ~A" 125 | name 126 | (mapcar #'name arg) 127 | bod 128 | ret))) 129 | 130 | (defun make-circuit (&key name arguments return-type body exec) 131 | (make-instance 'circuit 132 | :name name 133 | :body body 134 | :return-type return-type 135 | :arguments arguments 136 | :exec exec)) 137 | 138 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 139 | ;; Constraint Functionality 140 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 141 | 142 | (defmethod print-object ((obj constraint) stream) 143 | (print-unreadable-object (obj stream :type t) 144 | (format stream "~A ~A ~A" (privacy obj) (name obj) (typ obj)))) 145 | 146 | (-> make-constraint 147 | (&key (:name keyword) (:privacy privacy) (:type type-reference)) constraint) 148 | (defun make-constraint (&key (name (error "please provide name")) 149 | (privacy :private) 150 | type) 151 | (values 152 | (make-instance 'constraint :name name :type type :privacy privacy))) 153 | 154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 155 | ;; Type Declaration Functionalities ;; 156 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 | 158 | (defmethod print-object ((obj type-declaration) stream) 159 | (print-unreadable-object (obj stream) 160 | (with-accessors ((decl decl) (gen generics) (opt options) (name name)) obj 161 | (let ((plist (util:sycamore-symbol-map-plist opt))) 162 | ;; should abstract this bit out eventually but w/e 163 | (if plist 164 | (format stream "TYPE (~A ~A) ~{~A ~}= ~A" name plist gen decl) 165 | (format stream "TYPE ~A ~{~A ~}= ~A" name gen decl)))))) 166 | 167 | (defun make-type-declaration (&key 168 | (name (error "please provide name")) 169 | (options (sycamore:make-tree-map #'util:hash-compare)) 170 | generics 171 | (decl (error "please provide declaration"))) 172 | (make-instance 'type-declaration 173 | :decl decl :options options :generics generics :name name)) 174 | 175 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 176 | ;; Record Declaration Functionality 177 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 178 | 179 | (defmethod print-object ((obj record-decl) stream) 180 | (print-unreadable-object (obj stream :type t) 181 | (with-accessors ((cont contents)) obj 182 | (format stream "~{:~A ~A~^ ~}" (util:sycamore-symbol-map-plist cont))))) 183 | 184 | (defun make-record-declaration (&rest arguments &key &allow-other-keys) 185 | (make-instance 'record-decl 186 | :contents (util:sycamore-plist-symbol-map arguments) 187 | :order (mapcar #'car (alexandria:plist-alist arguments)))) 188 | 189 | (defun record-declaration->alist (record) 190 | (mapcar (lambda (field) 191 | (cons field (sycamore:tree-map-find (contents record) field nil))) 192 | (order record))) 193 | 194 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 195 | ;; Function Storage Func ;; 196 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 197 | -------------------------------------------------------------------------------- /src/pass/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; Package To make the pipeline available to the packages found here ; 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | 5 | (defpackage #:alu.pipeline.pipeline 6 | (:documentation "Provides The Alucard Pipeline signature to functions 7 | in this package file. This will be filled in by alu.pipeline") 8 | (:export 9 | :dump-entry-point 10 | :dump-entry-point-to-file 11 | :pipeline 12 | :print-vampir 13 | ;; Intermediate steps 14 | :to-typecheck 15 | :to-expand-away-records 16 | :to-primitive-circuit 17 | :to-vampir 18 | :type-check-expression)) 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;; Packages Regarding Expanding Away and Relocating Record Types 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | (defpackage #:alu.pass.expanded 25 | (:documentation "Provides argument expansion functionality. 26 | Including circuit declaration expansion, and function type 27 | expansion.") 28 | (:local-nicknames (:util :alu.utils) 29 | (:ir :alu.ir) 30 | (:storage :alu.storage)) 31 | (:use #:common-lisp #:serapeum) 32 | (:export 33 | ;; Type API 34 | :argument 35 | :argument-list 36 | :expand :original :expanded 37 | :make-expanded 38 | ;; Core API 39 | :full-arguments-from-storage 40 | :full-arguments-from-circuit 41 | :full-return-values 42 | :full-type-reference* 43 | :argument-names)) 44 | 45 | (defpackage #:alu.pass.relocation 46 | (:documentation "Provides mapping and functionality required to 47 | safely relocate record instances and generate out code which lacks records") 48 | (:local-nicknames (:util :alu.utils) 49 | (:ir :alu.ir) 50 | (:storage :alu.storage) 51 | (:expand :alu.pass.expanded) 52 | (:closure :alu.closure)) 53 | (:use #:common-lisp #:serapeum) 54 | (:export 55 | ;; Type API 56 | :rel 57 | :rel-closure 58 | :rel-forms 59 | :rel-p 60 | :make-rel 61 | ;; Core API 62 | :relocate-let 63 | :initial-closure-from-circuit 64 | :maps-to)) 65 | 66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 | ;; Packages Regarding Passes 68 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 69 | 70 | (defpackage #:alu.pass.evaluate-body 71 | (:documentation "Provides initial evaluation of the circuit body, modifying the 72 | circuits execution body and tracking caching") 73 | (:use #:common-lisp #:serapeum) 74 | (:local-nicknames (:util :alu.utils) 75 | (:ir :alu.ir) 76 | (:emit :alu.spec.emit)) 77 | (:export :evaluate-circuit-body :evaluate-and-cache-body)) 78 | 79 | (defpackage #:alu.pass.anf 80 | (:documentation "Provides an ANF pass for the alucard term") 81 | (:use #:common-lisp #:serapeum) 82 | (:local-nicknames (:util :alu.utils) 83 | (:spc :alu.spec)) 84 | (:export :normalize-expression)) 85 | 86 | (defpackage #:alu.pass.redundant 87 | (:documentation "Provides redundant let removal for alucard") 88 | (:use #:common-lisp #:serapeum) 89 | (:local-nicknames (#:util #:alu.utils) 90 | (#:ir #:alu.ir) 91 | (#:spc #:alu.vampir.spec) 92 | (#:storage #:alu.storage) 93 | (:closure :alu.closure)) 94 | (:export 95 | :remove-redundant-lets 96 | :replace-references 97 | :find-redundant-lets)) 98 | 99 | (defpackage #:alu.pass.extract 100 | (:documentation "Provides Extraction capabilities to vamp-ir") 101 | (:use #:common-lisp #:serapeum) 102 | (:local-nicknames (#:util #:alu.utils) 103 | (#:ir #:alu.ir) 104 | (#:spc #:alu.vampir.spec) 105 | (#:storage #:alu.storage)) 106 | (:export :circuit-to-alias)) 107 | 108 | (defpackage #:alu.pass 109 | (:documentation "Provides simplification passes to the Alucard Language") 110 | (:use #:common-lisp #:serapeum) 111 | (:local-nicknames (:util :alu.utils) 112 | (:ir :alu.ir) 113 | (:eval :alu.pass.evaluate-body) 114 | (:anf :alu.pass.anf) 115 | (:expand :alu.pass.expanded) 116 | (:relocate :alu.pass.relocation) 117 | (:term-op :alu.spec.term-op) 118 | (:storage :alu.storage) 119 | (:closure :alu.closure) 120 | (:redundant :alu.pass.redundant) 121 | (:extract :alu.pass.extract) 122 | (:vampir :alu.vampir)) 123 | (:export 124 | :linearize 125 | :linearize-body 126 | :filter-redundant-lets 127 | :expand-away-records 128 | :remove-void-bindings 129 | :primitive-circuit 130 | :rename-primitive-circuit 131 | :remove-type-information 132 | :return-void 133 | ;; Extraction 134 | :circuit-to-alias)) 135 | 136 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 137 | ;; Packages Regarding Extra Information Tracking 138 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 139 | 140 | (defpackage #:alu.pass.dependencies 141 | (:documentation "Provides an API for dependency tracking") 142 | (:use #:common-lisp #:serapeum) 143 | (:local-nicknames (:util :alu.utils) 144 | (:ir :alu.ir) 145 | (:pass :alu.pass) 146 | (:storage :alu.storage)) 147 | (:export 148 | :track-circuit-deps 149 | :track-circuit-deps*)) 150 | 151 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 152 | ;; Packages Regarding Packing Infrastructure 153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 154 | 155 | (defpackage #:alu.pass.pack 156 | (:documentation "Provides expansion logic for packing uniform and non uniform 157 | structures") 158 | (:use #:common-lisp #:serapeum) 159 | (:shadow #:array #:op #:+) 160 | (:local-nicknames (:util :alu.utils) 161 | (:ir :alu.ir) 162 | (:pass :alu.pass) 163 | (:storage :alu.storage) 164 | (:check.type :alu.typechecker.types) 165 | (:check :alu.typechecker) 166 | (:type-op :alu.spec.type-op) 167 | (:term-op :alu.spec.term-op) 168 | (:closure :alu.closure) 169 | (:pipeline :alu.pipeline.pipeline)) 170 | (:export :op :array 171 | :lookup-at :array-lookup-final-ref 172 | :final-ref-from-op)) 173 | 174 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 175 | ;; Packages Regarding Arrays 176 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 177 | (defpackage #:alu.pass.array 178 | (:documentation "Provides expansion logic for arrays") 179 | (:use #:common-lisp #:serapeum) 180 | (:local-nicknames (:util :alu.utils) 181 | (:ir :alu.ir) 182 | (:pack :alu.pass.pack) 183 | (:closure :alu.closure) 184 | (:storage :alu.storage) 185 | (:check :alu.typechecker)) 186 | (:export :handle-terms :handle-term)) 187 | 188 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 189 | ;; Packages Regarding the Pipeline 190 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 191 | 192 | (defpackage #:alu.pipeline 193 | (:documentation "Provides The Alucard Pipeline down to ANF") 194 | (:use #:common-lisp #:serapeum #:alu.pipeline.pipeline) 195 | (:local-nicknames (:util :alu.utils) 196 | (:ir :alu.ir) 197 | (:pass :alu.pass) 198 | (:vampir :alu.vampir) 199 | (:dep :alu.pass.dependencies) 200 | (:storage :alu.storage) 201 | (:array :alu.pass.array) 202 | (:check :alu.typechecker) 203 | (:log :alu.log)) 204 | (:export 205 | :dump-entry-point 206 | :dump-entry-point-to-file 207 | :pipeline 208 | :print-vampir 209 | ;; Intermediate steps 210 | :to-typecheck 211 | :to-expand-arrays 212 | :to-expand-away-records 213 | :to-primitive-circuit 214 | :to-vampir 215 | :type-check-expression)) 216 | -------------------------------------------------------------------------------- /src/pass/expand.lisp: -------------------------------------------------------------------------------- 1 | (in-package :alu.pass.expanded) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Type Declarations for expanded argument storage 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (deftype argument () 8 | `(or expand ir:constraint)) 9 | 10 | (deftype argument-list () 11 | "A constraint-list is a list of fully-expanded-terms" 12 | `(satisfies argument-list)) 13 | 14 | (defclass expand () 15 | ((original :initarg :original 16 | :type keyword 17 | :accessor original 18 | :documentation "The original name the argument had") 19 | (expanded :initarg :expanded 20 | :type list 21 | :accessor expanded 22 | :documentation 23 | "The fully expanded argument alist from keyword to `ir:constraint'"))) 24 | 25 | (defun make-expanded (&key original expanded) 26 | (make-instance 'expand :original original :expanded expanded)) 27 | 28 | (defmethod print-object ((obj expand) stream) 29 | (print-unreadable-object (obj stream :type t) 30 | (format stream "~A ~A" (original obj) (expanded obj)))) 31 | 32 | 33 | (defun argument-list (list) 34 | (and (listp list) 35 | (every (lambda (x) (typep x 'argument)) list))) 36 | 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | ;; Core API 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | 41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 | ;; Argument Expansion API 43 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 44 | 45 | ;; (calculate-full-arguments-from-storage :poly) 46 | (-> full-arguments-from-storage (keyword) argument-list) 47 | (defun full-arguments-from-storage (name) 48 | "Calculates the full argument list with records being expanded into 49 | the `expand' type" 50 | (let ((circuit (storage:lookup-function name))) 51 | (when circuit 52 | (etypecase-of ir:function-type circuit 53 | (ir:primitive nil) 54 | (ir:circuit (full-arguments-from-circuit circuit)))))) 55 | 56 | (-> full-arguments-from-circuit (ir:circuit) argument-list) 57 | (defun full-arguments-from-circuit (circuit) 58 | "Calculates the full argument list with records being expanded into 59 | being the `expand' type" 60 | (mapcar #'expand-type-into-constituents 61 | (ir:arguments circuit))) 62 | 63 | (-> argument-names (argument-list) list) 64 | (defun argument-names (argument-list) 65 | (mapcan (lambda (x) 66 | (etypecase-of argument x 67 | (ir:constraint (list (ir:name x))) 68 | (expand (argument-names (util:alist-values (expanded x)))))) 69 | argument-list)) 70 | 71 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 72 | ;; Return Type Expansion API 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | 75 | (-> full-return-values (keyword) (or ir:type-reference list)) 76 | (defun full-return-values (name) 77 | "Expands the return type into the constitute fields recursively and 78 | gives back the original output type, an empty list if primitive, or an 79 | alist 80 | 81 | alist-return-example: 82 | ((:TIME (:X . #) 83 | (:Y . #)) 84 | (:PLANE (:X . #) 85 | (:Y . #)))" 86 | (let ((circuit (storage:lookup-function name))) 87 | (when circuit 88 | (etypecase-of ir:function-type circuit 89 | (ir:primitive nil) 90 | (ir:circuit (full-type-reference* (ir:return-type circuit))))))) 91 | 92 | (-> full-type-reference* 93 | (ir:type-reference &optional sycamore:tree-set) 94 | (or ir:type-reference list)) 95 | (defun full-type-reference* (ref &optional 96 | (seen-set (sycamore:tree-set #'util:hash-compare))) 97 | "Expands a type reference into it's expanded members recursively" 98 | (let* ((name 99 | (etypecase-of ir:type-reference ref 100 | (ir:application (ir:name (ir:func ref))) 101 | (ir:reference-type (ir:name ref)))) 102 | (new-set 103 | (sycamore:tree-set-insert seen-set name))) 104 | (if (sycamore:tree-set-find seen-set name) 105 | ref 106 | (let ((expand (expand-type-fields name))) 107 | (if expand 108 | (mapcar (lambda (x) 109 | (let ((expand* (full-type-reference* (cdr x) new-set))) 110 | (cons (car x) expand*))) 111 | expand) 112 | ref))))) 113 | 114 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 115 | ;; Helper Functions 116 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 117 | 118 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 119 | ;; Expanding Helpers 120 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 121 | 122 | (-> expand-type-into-constituents (ir:constraint) argument) 123 | (defun expand-type-into-constituents (circ) 124 | "Takes a constraint and expands user defined types into the proper 125 | components, otherwise returns the type given back." 126 | (with-accessors ((name ir:name) (typ ir:typ) (priv ir:privacy)) circ 127 | 128 | (let ((expanded-list (full-type-reference* typ))) 129 | (when (and (typep typ 'ir:application) 130 | (listp expanded-list)) 131 | (error "Generics in custom user types is not supported yet")) 132 | (assure argument 133 | (if (listp expanded-list) 134 | (make-expanded 135 | :original name 136 | :expanded (mapcar (lambda (x) 137 | (constraint-alist-from-dotted-pair* x priv name)) 138 | expanded-list)) 139 | circ))))) 140 | 141 | (-> expand-type-reference (ir:type-reference) list) 142 | (defun expand-type-reference (ref) 143 | (expand-type-fields 144 | (etypecase-of ir:type-reference ref 145 | (ir:application (ir:name (ir:func ref))) 146 | (ir:reference-type (ir:name ref))))) 147 | 148 | (-> expand-type-fields (keyword) list) 149 | (defun expand-type-fields (name) 150 | "Expands the given type to an alist of (:field-name . `ir:type-reference')" 151 | (values 152 | (let ((lookup (storage:lookup-type name))) 153 | (etypecase-of (or null ir:type-storage) lookup 154 | (null nil) 155 | (ir:primitive nil) 156 | (ir:type-declaration 157 | (etypecase-of ir:type-format (ir:decl lookup) 158 | (ir:record-decl 159 | (ir:record-declaration->alist (ir:decl lookup))) 160 | (ir:sum-decl 161 | (error "sum types are not supported yet")))))))) 162 | 163 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 164 | ;; Constraint Creation 165 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 166 | 167 | (-> constraint-alist-from-dotted-pair* (list ir:privacy keyword) list) 168 | (defun constraint-alist-from-dotted-pair* (list privacy prefix) 169 | "creates a constraint given an alist, a privacy modified, and the 170 | original argument name. 171 | 172 | (constraint-alist-from-dotted-pair* 173 | `(:hi . ((:bah . ,(ir:make-type-reference :name :int)) 174 | (:baz . ,(ir:make-type-reference :name :int)))) 175 | :private 176 | :prefix) 177 | 178 | ===> 179 | 180 | (:HI 181 | . #>) 183 | (:BAZ . #>))>) 184 | 185 | (constraint-alist-from-dotted-pair* 186 | `(:name . ,(ir:make-type-reference :name :int)) :private :prefix) 187 | 188 | ===> 189 | 190 | (:NAME . #>) 191 | " 192 | (destructuring-bind (key . cont) list 193 | (let ((new-name (naming-scheme prefix key))) 194 | (cons 195 | key 196 | (if (listp cont) 197 | (make-expanded 198 | :original new-name 199 | :expanded (mapcar (lambda (p) 200 | (constraint-alist-from-dotted-pair* p privacy new-name)) 201 | cont)) 202 | (ir:make-constraint :name new-name :privacy privacy :type cont)))))) 203 | 204 | 205 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 206 | ;; Utility Helpers 207 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 208 | 209 | (-> naming-scheme (keyword keyword) keyword) 210 | (defun naming-scheme (prefix name) 211 | "Derives the proper name for the expanded name from the original field 212 | name, the record name" 213 | (intern (concatenate 'string (symbol-name prefix) "-" (symbol-name name)) 214 | 'keyword)) 215 | --------------------------------------------------------------------------------