├── .gitignore ├── README.md ├── avm-test.asd ├── avm.asd ├── samples ├── julia.lisp ├── mandelbrot.c ├── mandelbrot.lisp ├── nbody.c ├── nbody.lisp ├── sph.lisp └── vector-add.lisp ├── src ├── api │ ├── array.lisp │ ├── cuda.lisp │ ├── defkernel.lisp │ ├── kernel-manager.lisp │ └── macro.lisp ├── avm.lisp └── lang │ ├── appenv.lisp │ ├── binarize.lisp │ ├── built-in.lisp │ ├── compiler │ ├── cuda │ │ ├── built-in.lisp │ │ ├── compile-type.lisp │ │ ├── compile.lisp │ │ ├── k-normal.lisp │ │ └── lang.lisp │ └── lisp │ │ ├── built-in.lisp │ │ ├── compile-type.lisp │ │ ├── compile.lisp │ │ ├── lang.lisp │ │ └── varenv.lisp │ ├── convert-functions.lisp │ ├── convert-implicit-progn.lisp │ ├── data.lisp │ ├── expand-macro.lisp │ ├── free-variable.lisp │ ├── funenv.lisp │ ├── infer.lisp │ ├── kernel.lisp │ ├── lang.lisp │ ├── symbol.lisp │ ├── syntax.lisp │ ├── type.lisp │ ├── typenv.lisp │ └── unienv.lisp └── t ├── api ├── array.lisp ├── cuda.lisp └── macro.lisp ├── avm.lisp ├── lang ├── compiler │ ├── cuda │ │ ├── compile.lisp │ │ └── k-normal.lisp │ └── lisp │ │ └── compile.lisp ├── convert-functions.lisp ├── convert-implicit-progn.lisp ├── expand-macro.lisp └── free-variable.lisp └── util.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* 9 | .DS_Store -------------------------------------------------------------------------------- /avm-test.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test-asd 8 | (:use :cl :asdf)) 9 | (in-package :avm-test-asd) 10 | 11 | (defsystem avm-test 12 | :author "Masayuki Takagi" 13 | :license "MIT" 14 | :depends-on (:avm 15 | :prove) 16 | :components ((:module "t" 17 | :components 18 | ((:test-file "avm") 19 | (:file "util") 20 | (:module "lang" 21 | :serial t 22 | :components 23 | ((:test-file "expand-macro") 24 | (:test-file "convert-implicit-progn") 25 | (:test-file "convert-functions") 26 | (:test-file "free-variable") 27 | (:module "compiler" 28 | :serial t 29 | :components 30 | ((:module "lisp" 31 | :serial t 32 | :components 33 | ((:test-file "compile"))) 34 | (:module "cuda" 35 | :serial t 36 | :components 37 | ((:test-file "k-normal") 38 | (:test-file "compile"))) 39 | )))) 40 | (:module "api" 41 | :serial t 42 | :components 43 | ((:test-file "cuda") 44 | (:test-file "array") 45 | (:test-file "macro")))))) 46 | :description "Test system for avm" 47 | 48 | :defsystem-depends-on (:prove-asdf) 49 | :perform (test-op :after (op c) 50 | (funcall (intern #.(string :run-test-system) :prove-asdf) c) 51 | (asdf:clear-system c))) 52 | -------------------------------------------------------------------------------- /avm.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-asd 8 | (:use :cl :asdf)) 9 | (in-package :avm-asd) 10 | 11 | (defsystem avm 12 | :version "0.1" 13 | :author "Masayuki Takagi" 14 | :license "MIT" 15 | :depends-on (:cl-tuples 16 | :cl-pattern 17 | :cl-unification 18 | :cl-cuda 19 | :bordeaux-threads) 20 | :components ((:module "src" 21 | :serial t 22 | :components 23 | ((:file "avm") 24 | (:module "lang" 25 | :serial t 26 | :components 27 | ((:file "symbol") 28 | (:file "data") 29 | (:file "type") 30 | (:file "syntax") 31 | (:file "built-in") 32 | (:file "funenv") 33 | (:file "expand-macro") 34 | (:file "convert-implicit-progn") 35 | (:file "binarize") 36 | (:file "convert-functions") 37 | (:file "free-variable") 38 | (:file "unienv") 39 | (:file "typenv") 40 | (:file "appenv") 41 | (:file "infer") 42 | (:file "kernel") 43 | (:file "lang") 44 | (:module "compiler" 45 | :serial t 46 | :components 47 | ((:module "lisp" 48 | :serial t 49 | :components 50 | ((:file "built-in") 51 | (:file "compile-type") 52 | (:file "varenv") 53 | (:file "compile") 54 | (:file "lang"))) 55 | (:module "cuda" 56 | :serial t 57 | :components 58 | ((:file "built-in") 59 | (:file "k-normal") 60 | (:file "compile-type") 61 | (:file "compile") 62 | (:file "lang"))) 63 | )))) 64 | (:module "api" 65 | :serial t 66 | :components 67 | ((:file "cuda") 68 | (:file "array") 69 | (:file "kernel-manager") 70 | (:file "defkernel") 71 | (:file "macro")))))) 72 | :description "Efficient and expressive arrayed vector math library with multi-threading and CUDA support." 73 | :long-description 74 | #.(with-open-file (stream (merge-pathnames 75 | #p"README.md" 76 | (or *load-pathname* *compile-file-pathname*)) 77 | :if-does-not-exist nil 78 | :direction :input) 79 | (when stream 80 | (let ((seq (make-array (file-length stream) 81 | :element-type 'character 82 | :fill-pointer t))) 83 | (setf (fill-pointer seq) (read-sequence seq stream)) 84 | seq))) 85 | :in-order-to ((test-op (test-op avm-test)))) 86 | -------------------------------------------------------------------------------- /samples/julia.lisp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/takagi/avm/c6d3c622d21ee3df3e53937df3c8c266abd1d106/samples/julia.lisp -------------------------------------------------------------------------------- /samples/mandelbrot.c: -------------------------------------------------------------------------------- 1 | /* 2 | * To compile and run: 3 | * $ gcc -O3 -o mandelbrot mandelbrot.c 4 | * $ ./mandelbrot > mandelbrot.pgm 5 | */ 6 | 7 | #include 8 | #include 9 | #include 10 | 11 | #define MIN(a, b) (((a) < (b)) ? (a) : (b)) 12 | 13 | int main(int argc, char** argv) 14 | { 15 | int i, m; 16 | int* xs; 17 | struct timeval start_time, end_time; 18 | 19 | // Allocate memory. 20 | xs = (int*)malloc(2048*2048*sizeof(int)); 21 | if (!xs) exit(-1); 22 | 23 | // Get start time. 24 | gettimeofday(&start_time, NULL); 25 | 26 | // Compute Mandelbrot set. 27 | for (i = 0; i < 2048*2048; ++i) { 28 | double x = 0.0, y = 0.0; 29 | double a = (double)(i % 2048 - 512) / 1024.0; 30 | double b = (double)(i / 2048 - 1024) / 1024.0; 31 | xs[i] = 0; 32 | for (m = 1; m < 100; ++m) { 33 | double x1 = x*x - y*y - a; 34 | double y1 = 2*x*y - b; 35 | if (x1*x1 + y1*y1 > 4.0) { 36 | xs[i] = m; 37 | break; 38 | } 39 | x = x1; y = y1; 40 | } 41 | } 42 | 43 | // Get end time and show elapsed time. 44 | gettimeofday(&end_time, NULL); 45 | double sec = (double)(end_time.tv_sec - start_time.tv_sec); 46 | double micro = (double)(end_time.tv_usec - start_time.tv_usec); 47 | double passed = sec + micro / 1000.0 / 1000.0; 48 | fprintf( stderr, "Elapsed: %f [sec]\n", passed ); 49 | 50 | // Output Mandelbrot set in PGM format. 51 | printf("P2\n"); 52 | printf("2048 2048\n"); 53 | printf("255\n"); 54 | for (i = 0; i < 2048*2048; ++i) { 55 | printf("%d\n", MIN(255, xs[i]*8)); 56 | } 57 | 58 | // Free memory. 59 | free(xs); 60 | 61 | return 0; 62 | } 63 | -------------------------------------------------------------------------------- /samples/mandelbrot.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.samples.mandelbrot 8 | (:use :cl 9 | :avm) 10 | (:export :main)) 11 | (in-package :avm.samples.mandelbrot) 12 | 13 | 14 | ;(defkernel-symbol-macro nmax 100) 15 | 16 | (defkernel mandelbrot (xs) 17 | (labels ((aux (x y a b m) 18 | (if (< m 100) 19 | (let ((x1 (- (* x x) (* y y) a)) 20 | (y1 (- (* 2.0 x y) b))) 21 | (if (> (+ (* x1 x1) (* y1 y1)) 4.0) 22 | m 23 | (aux x1 y1 a b (+ m 1)))) 24 | 0))) 25 | (let ((a (/ (float (- (mod i 2048) 512)) 1024.0)) 26 | (b (/ (float (- (/ i 2048) 1024)) 1024.0))) 27 | (setf (aref xs i) (aux 0.0 0.0 a b 1))))) 28 | 29 | (defun draw-mandelbrot (pathname xs) 30 | (with-open-file (out pathname :direction :output 31 | :if-does-not-exist :create 32 | :if-exists :supersede) 33 | (write-line "P2" out) 34 | (write-line "2048 2048" out) 35 | (write-line "255" out) 36 | (dotimes (i (* 2048 2048)) 37 | (princ (min 255 (* 8 (array-aref xs i))) out) 38 | (terpri out)))) 39 | 40 | (defun main (&optional dev-id) 41 | (with-cuda (dev-id) 42 | (with-arrays ((xs int (* 2048 2048))) 43 | (time (progn 44 | (mandelbrot xs) 45 | (synchronize))) 46 | (draw-mandelbrot #P"mandelbrot.pgm" xs)))) 47 | -------------------------------------------------------------------------------- /samples/nbody.c: -------------------------------------------------------------------------------- 1 | /* 2 | * To compile and run: 3 | * $ gcc -O3 -o nbody nbody.c -lm 4 | * $ ./nbody > nbody.pgm 5 | */ 6 | 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | #define SWAP(x, y, T) do { T SWAP = x; x = y; y = SWAP; } while (0) 13 | 14 | struct float4 { 15 | float x, y, z, w; 16 | }; 17 | 18 | float rsqrt(float x){ 19 | // Use sqrt, not sqrtf, for fair comparison with SBCL. 20 | return 1.0f / sqrt(x); 21 | } 22 | 23 | struct float4 acceleration1(struct float4 xi, struct float4 xj) 24 | { 25 | struct float4 r, a; 26 | float dist_sqr, inv_dist, inv_dist_cube, scale; 27 | 28 | r.x = xj.x - xi.x; 29 | r.y = xj.y - xi.y; 30 | r.z = xj.z - xi.z; 31 | r.w = 0.0f; 32 | 33 | dist_sqr = r.x * r.x + r.y * r.y + r.z * r.z + r.w * r.w 34 | + 0.1f * 0.1f; /* add softening factor */ 35 | inv_dist = rsqrt(dist_sqr); 36 | inv_dist_cube = inv_dist * inv_dist * inv_dist; 37 | scale = xj.w * inv_dist_cube; 38 | 39 | a.x = r.x * scale; 40 | a.y = r.y * scale; 41 | a.z = r.z * scale; 42 | a.w = r.w * scale; 43 | 44 | return a; 45 | } 46 | 47 | struct float4 acceleration(struct float4 xi, struct float4* xs0, int n) 48 | { 49 | int j; 50 | struct float4 a = { 0.0f, 0.0f, 0.0f, 0.0f }; 51 | struct float4 a1, xj; 52 | 53 | for (j = 0; j < n; ++j) { 54 | xj = xs0[j]; 55 | a1 = acceleration1(xi, xj); 56 | a.x += a1.x; 57 | a.y += a1.y; 58 | a.z += a1.z; 59 | a.w += a1.w; 60 | } 61 | 62 | return a; 63 | } 64 | 65 | void integrate_bodies(struct float4* xs, struct float4* xs0, struct float4* vs, 66 | int n, float dt) 67 | { 68 | int i; 69 | struct float4 a, x; 70 | 71 | for (i = 0; i < n; ++i) { 72 | x = xs0[i]; 73 | a = acceleration(x, xs0, n); 74 | 75 | vs[i].x += a.x * dt; 76 | vs[i].y += a.y * dt; 77 | vs[i].z += a.z * dt; 78 | vs[i].w += a.w * dt; 79 | 80 | xs[i].x = x.x + vs[i].x * dt; 81 | xs[i].y = x.y + vs[i].y * dt; 82 | xs[i].z = x.z + vs[i].z * dt; 83 | xs[i].w = x.w + vs[i].w * dt; 84 | } 85 | 86 | return; 87 | } 88 | 89 | void init_rand() { 90 | time_t t; 91 | srand((unsigned)time(&t)); 92 | return; 93 | } 94 | 95 | float random_(float min, float max) { 96 | return (float)rand() / RAND_MAX * (max - min) + min; 97 | } 98 | 99 | void initialize(struct float4* xs, struct float4* vs, int n) 100 | { 101 | int i; 102 | 103 | for (i = 0; i < n; ++i) { 104 | xs[i].x = random_(-3.0f, 3.0f); 105 | xs[i].y = random_(-3.0f, 3.0f); 106 | xs[i].z = random_(-3.0f, 3.0f); 107 | xs[i].w = 1.0f; 108 | vs[i].x = vs[i].y = vs[i].z = vs[i].w = 0.0f; 109 | } 110 | 111 | return; 112 | } 113 | 114 | void plot_body(int* img, int x, int y) 115 | { 116 | int i, j; 117 | 118 | for (j = y - 5; j < y + 5; ++j) { 119 | if (0 <= j && j < 1024) { 120 | for (i = x - 5; i < x + 5; ++i ) { 121 | if (0 <= i && i < 1024) { 122 | img[i + j * 1024] = 255; 123 | } 124 | } 125 | } 126 | } 127 | 128 | return; 129 | } 130 | 131 | void output_bodies(struct float4* xs, int n) 132 | { 133 | int* img; 134 | int i, j, k, x, y; 135 | 136 | // Allocate image map. 137 | img = (int*)malloc(1024 * 1024 * sizeof(int)); 138 | if (!img) exit(-1); 139 | 140 | // Make image map from position. 141 | for (i = 0; i < n; ++i) { 142 | x = (int)((xs[i].x + 1.0f) * 512.0f); 143 | y = (int)((xs[i].y + 1.0f) * 512.0f); 144 | plot_body(img, x, y); 145 | } 146 | 147 | // Output image map in PGM format. 148 | printf("P2\n"); 149 | printf("1024 1024\n"); 150 | printf("255\n"); 151 | for (j = 0; j < 1024; ++j) { 152 | for (i = 0; i < 1024; ++i) { 153 | printf("%d ", img[i + j * 1024]); 154 | } 155 | printf("\n"); 156 | } 157 | 158 | // Free image map. 159 | free(img); 160 | 161 | return; 162 | } 163 | 164 | int main(int argc, char** argv) 165 | { 166 | int i, j, k; 167 | int n = 32768; 168 | struct float4 *xs, *xs0, *vs, *tmp; 169 | float dt = 0.001f; 170 | struct timeval start_time, end_time; 171 | int* img; 172 | 173 | // Allocate memory. 174 | xs = (struct float4*)malloc(n * sizeof(struct float4)); 175 | if (!xs) exit(-1); 176 | 177 | xs0 = (struct float4*)malloc(n * sizeof(struct float4)); 178 | if (!xs0) exit(-1); 179 | 180 | vs = (struct float4*)malloc(n * sizeof(struct float4)); 181 | if (!vs) exit(-1); 182 | 183 | // Initialize position and velocity. 184 | init_rand(); 185 | initialize(xs, vs, n); 186 | 187 | // Get start time. 188 | gettimeofday(&start_time, NULL); 189 | 190 | // Simulate bodies. 191 | for (i = 0; i < 10; ++i) { 192 | SWAP(xs, xs0, struct float4*); 193 | integrate_bodies(xs, xs0, vs, n, dt); 194 | } 195 | 196 | // Get end time and show elapsed time. 197 | gettimeofday(&end_time, NULL); 198 | double sec = (double)(end_time.tv_sec - start_time.tv_sec); 199 | double micro = (double)(end_time.tv_usec - start_time.tv_usec); 200 | double passed = sec + micro / 1000.0 / 1000.0; 201 | fprintf(stderr, "Elapsed: %f [sec]\n", passed); 202 | 203 | // Output bodies in PGM format. 204 | output_bodies(xs, n); 205 | 206 | // Free memory. 207 | free(xs); 208 | free(xs0); 209 | free(vs); 210 | 211 | return 0; 212 | } 213 | -------------------------------------------------------------------------------- /samples/nbody.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.samples.nbody 8 | (:use :cl 9 | :avm) 10 | (:export :main)) 11 | (in-package :avm.samples.nbody) 12 | 13 | 14 | (defkernel acceleration1 (xi xj) 15 | (let* ((r (float3 (- (float4-x xj) (float4-x xi)) 16 | (- (float4-y xj) (float4-y xi)) 17 | (- (float4-z xj) (float4-z xi)))) 18 | (dist-sqr (+ (dot r r) 19 | (* 0.1 0.1))) ; add softening factor 20 | (inv-dist (rsqrt dist-sqr)) 21 | (inv-dist-cube (* inv-dist inv-dist inv-dist)) 22 | (scale (* (float4-w xj) inv-dist-cube))) 23 | (float4 (* scale (float3-x r)) 24 | (* scale (float3-y r)) 25 | (* scale (float3-z r)) 26 | 0.0))) 27 | 28 | (defkernel acceleration (xi xs0) 29 | ;; TODO: ITER macro 30 | ;; TODO: Accept free variables 31 | (labels ((aux (xi xs0 j a) 32 | (if (< j n) 33 | (let ((xj (aref xs0 j))) 34 | (aux xi xs0 (+ j 1) (+ a (acceleration1 xi xj)))) 35 | a))) 36 | (aux xi xs0 0 (float4 0.0 0.0 0.0 0.0)))) 37 | 38 | (defkernel integrate-bodies (xs xs0 vs dt) 39 | ;; Compute acceleration. 40 | (let* ((x (aref xs0 i)) 41 | (a (acceleration x xs0))) 42 | ;; Update velocity. 43 | (setf (aref vs i) (+ (aref vs i) (*. a dt))) 44 | ;; Update position. 45 | (setf (aref xs i) (+ x (*. (aref vs i) dt))))) 46 | 47 | (defun initialize (xs vs) 48 | (dotimes (i (array-size xs)) 49 | (let ((x (- (random 2.0) 1.0)) 50 | (y (- (random 2.0) 1.0)) 51 | (z (- (random 2.0) 1.0))) 52 | (setf (array-aref xs i) (values x y z 1.0))) 53 | (setf (array-aref vs i) (values 0.0 0.0 0.0 0.0)))) 54 | 55 | (defun plot (img x y) 56 | ;; TODO: Use gaussian. 57 | (loop for i from (- x 5) below (+ x 5) do 58 | (loop for j from (- y 5) below (+ y 5) 59 | when (and (<= 0 i 1023) 60 | (<= 0 j 1023)) 61 | do (setf (aref img i j) 255)))) 62 | 63 | (defun output-bodies (pathname xs) 64 | (let ((img (make-array '(1024 1024) :element-type 'fixnum 65 | :initial-element 0))) 66 | ;; Make image map from positions. 67 | (dotimes (i (array-size xs)) 68 | (multiple-value-bind (x y z w) (array-aref xs i) 69 | (declare (ignore z w)) 70 | (let ((x1 (truncate (* (+ x 1.0) 512.0))) 71 | (y1 (truncate (* (+ y 1.0) 512.0)))) 72 | (plot img x1 y1)))) 73 | ;; Output image map. 74 | (with-open-file (out pathname :direction :output 75 | :if-does-not-exist :create 76 | :if-exists :supersede) 77 | (write-line "P2" out) 78 | (write-line "1024 1024" out) 79 | (write-line "255" out) 80 | (dotimes (i 1024) 81 | (dotimes (j 1024) 82 | (princ (aref img i j) out) 83 | (princ " " out)) 84 | (terpri out))))) 85 | 86 | (defun main (&optional dev-id) 87 | (let ((n 32768) 88 | (dt 0.001)) 89 | (with-cuda (dev-id) 90 | (with-arrays ((xs float4 n) 91 | (xs0 float4 n) 92 | (vs float4 n)) 93 | ;; Initialize poistion and velocity. 94 | (initialize xs vs) 95 | ;; Simulate bodies. 96 | (time (progn 97 | (loop repeat 10 98 | do (rotatef xs xs0) 99 | (integrate-bodies xs xs0 vs dt)) 100 | (synchronize))) 101 | ;; Output bodies. 102 | (output-bodies "nbody.pgm" xs))))) 103 | -------------------------------------------------------------------------------- /samples/sph.lisp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/takagi/avm/c6d3c622d21ee3df3e53937df3c8c266abd1d106/samples/sph.lisp -------------------------------------------------------------------------------- /samples/vector-add.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.samples.vector-add 8 | (:use :cl 9 | :avm) 10 | (:export :main)) 11 | (in-package :avm.samples.vector-add) 12 | 13 | 14 | (defkernel vector-add (c a b) 15 | (setf (aref c i) (the int (+ (aref a i) (aref b i))))) 16 | 17 | (defun random-init (array n) 18 | (dotimes (i n) 19 | (setf (array-aref array i) (random 100)))) 20 | 21 | (defun verify-result (as bs cs n) 22 | (dotimes (i n) 23 | (let ((a (array-aref as i)) 24 | (b (array-aref bs i)) 25 | (c (array-aref cs i))) 26 | (unless (= (+ a b) c) 27 | (error "Verification failed: i=~A, a=~A, b=~A, c=~A" i a b c)))) 28 | (format t "Successfully verified.~%")) 29 | 30 | (defun main (n &optional dev-id) 31 | (with-cuda (dev-id) 32 | (with-arrays ((a int n) 33 | (b int n) 34 | (c int n)) 35 | (random-init a n) 36 | (random-init b n) 37 | (time 38 | (vector-add c a b)) 39 | (verify-result a b c n)))) 40 | -------------------------------------------------------------------------------- /src/api/cuda.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.api.cuda 8 | (:use :cl 9 | :avm) 10 | (:import-from :alexandria 11 | :once-only) 12 | (:export :with-cuda 13 | :*use-cuda-p* 14 | :cuda-state-not-available-p 15 | :cuda-state-available-p 16 | :cuda-state-used-p 17 | :cuda-available-p 18 | :synchronize)) 19 | (in-package :avm.api.cuda) 20 | 21 | 22 | ;; 23 | ;; CUDA 24 | 25 | (defvar *use-cuda-p* nil) 26 | 27 | (defmacro with-cuda ((dev-id) &body body) 28 | (once-only (dev-id) 29 | `(flet ((aux () ,@body)) 30 | (if (and (not cl-cuda:*sdk-not-found*) 31 | ,dev-id) 32 | (let ((*use-cuda-p* t)) 33 | (cl-cuda:with-cuda (,dev-id) 34 | (aux))) 35 | (aux))))) 36 | 37 | (defun cuda-state-not-available-p () 38 | (not (boundp 'cl-cuda:*cuda-context*))) 39 | 40 | (defun cuda-state-available-p () 41 | (and (boundp 'cl-cuda:*cuda-context*) 42 | (not *use-cuda-p*))) 43 | 44 | (defun cuda-state-used-p () 45 | (and (boundp 'cl-cuda:*cuda-context*) 46 | *use-cuda-p* 47 | t)) 48 | 49 | (defun cuda-available-p () 50 | ;; Equivalent to CUDA state Available or Used. 51 | (and (boundp 'cl-cuda:*cuda-context*) 52 | t)) 53 | 54 | (defun synchronize () 55 | (when (cuda-available-p) 56 | (cl-cuda:synchronize-context))) 57 | -------------------------------------------------------------------------------- /src/api/defkernel.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.api.defkernel 8 | (:use :cl 9 | :avm 10 | :avm.api.cuda 11 | :avm.api.array 12 | :avm.api.kernel-manager) 13 | (:export :defkernel 14 | :*number-of-threads* 15 | :*compile-on-runtime* 16 | :defkernel-macro)) 17 | (in-package :avm.api.defkernel) 18 | 19 | 20 | ;; 21 | ;; DEFKERNEL 22 | 23 | (defun compute-ranges (n size) 24 | (let ((size1 (ceiling (/ size n)))) 25 | (let (ranges) 26 | (do ((begin 0 (+ begin size1)) 27 | (end size1 (min (+ end size1) size))) 28 | ((>= begin size) (nreverse ranges)) 29 | (push (list begin end) ranges))))) 30 | 31 | (defun compute-dimension (args) 32 | (let ((arrays (remove-if-not #'array-p args))) 33 | (or (and arrays 34 | (array-size (car arrays))) 35 | (error "SIZE required if no array arguments.")))) 36 | 37 | (defun array-lisp-bindings (args1 args) 38 | (loop for arg1 in args1 39 | for arg in args 40 | collect `(,arg1 (if (array-p ,arg) 41 | (avm.api.array::array-tuple-array ,arg) 42 | ,arg)))) 43 | 44 | (defun array-cuda-bindings (args1 args) 45 | (loop for arg1 in args1 46 | for arg in args 47 | collect `(,arg1 (if (array-p ,arg) 48 | (avm.api.array::array-device-ptr ,arg) 49 | ,arg)))) 50 | 51 | (defvar *number-of-threads* 1) 52 | 53 | (defun defun-entry-function-form (name lisp-name cuda-name args) 54 | (let ((args1 (map-into (make-list (length args)) #'gensym)) 55 | (arg (gensym))) 56 | `(defun ,name (,@args &key size) 57 | (let ((n (or size (compute-dimension (list ,@args))))) 58 | (declare (type fixnum n)) 59 | (cond 60 | ((cuda-state-used-p) 61 | ;; Synchronize arrays appearing in arguments. 62 | (loop for ,arg in (list ,@args) 63 | when (array-p ,arg) 64 | do (array-ensure-cuda-up-to-date ,arg) 65 | (array-set-cuda-dirty ,arg)) 66 | ;; Launch kernel. 67 | (let ,(array-cuda-bindings args1 args) 68 | (let ((grid-dim (list (ceiling n 64) 1 1)) 69 | (block-dim '(64 1 1))) 70 | (,cuda-name n ,@args1 :grid-dim grid-dim 71 | :block-dim block-dim)))) 72 | ((< 1 *number-of-threads*) 73 | ;; Synchronize arrays appearing in arguments. 74 | (when (cuda-available-p) 75 | (loop for ,arg in (list ,@args) 76 | when (array-p ,arg) 77 | do (array-ensure-lisp-up-to-date ,arg) 78 | (array-set-lisp-dirty ,arg))) 79 | ;; Launch kernel. 80 | (let (,@(array-lisp-bindings args1 args) 81 | (ranges (compute-ranges *number-of-threads* n))) 82 | (let (threads) 83 | (dolist (range ranges) 84 | (destructuring-bind (begin end) range 85 | (push (bt:make-thread 86 | #'(lambda () 87 | (loop for i from begin below end 88 | do (,lisp-name i n ,@args1)))) 89 | threads))) 90 | (loop for thread in threads 91 | do (bt:join-thread thread))))) 92 | (t 93 | ;; Synchronize arrays appearing in arguments. 94 | (when (cuda-available-p) 95 | (loop for ,arg in (list ,@args) 96 | when (array-p ,arg) 97 | do (array-ensure-lisp-up-to-date ,arg) 98 | (array-set-lisp-dirty ,arg))) 99 | ;; Launch kernel. 100 | (let ,(array-lisp-bindings args1 args) 101 | (dotimes (i n) 102 | (declare (type fixnum i)) 103 | (,lisp-name i n ,@args1))))))))) 104 | 105 | (defun defkernel-form (manager name args body) 106 | (multiple-value-bind (lisp-name lisp-form cuda-name cuda-form 107 | include-vector-type-p) 108 | (kernel-manager-define-function manager name args body) 109 | (let ((entry-function-form 110 | (defun-entry-function-form name lisp-name cuda-name args))) 111 | `(progn 112 | ;; Define Lisp kernel. 113 | ,lisp-form 114 | ;; Define CUDA kernel. 115 | ,cuda-form 116 | ;; Define entry function. 117 | ,@(when (not include-vector-type-p) 118 | (list entry-function-form)))))) 119 | 120 | (defvar *compile-on-runtime* nil) 121 | 122 | (defmacro defkernel (name args &body body) 123 | (if (not *compile-on-runtime*) 124 | (defkernel-form *kernel-manager* name args body) 125 | `(eval-when (:compile-toplevel :load-toplevel :execute) 126 | (eval 127 | (defkernel-form *kernel-manager* ',name ',args ',body))))) 128 | 129 | 130 | ;; 131 | ;; DEFKERNEL-MACRO 132 | 133 | (defmacro defkernel-macro (name args &body body) 134 | `(kernel-manager-define-macro *kernel-manager* ',name ',args ',body)) 135 | -------------------------------------------------------------------------------- /src/api/kernel-manager.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.api.kernel-manager 8 | (:use :cl 9 | :avm 10 | :avm.lang.symbol 11 | :avm.lang 12 | :avm.lang.type 13 | :avm.lang.kernel) 14 | (:export :make-kernel-manager 15 | :*kernel-manager* 16 | :kernel-manager-define-function 17 | :kernel-manager-define-macro 18 | :kernel-manager-expand-macro-1 19 | :kernel-manager-expand-macro 20 | )) 21 | (in-package :avm.api.kernel-manager) 22 | 23 | 24 | ;; 25 | ;; Kernel manager 26 | 27 | (defstruct (kernel-manager (:constructor %make-kernel-manager)) 28 | (kernel :kernel :read-only t)) 29 | 30 | (defun make-kernel-manager () 31 | (%make-kernel-manager :kernel (make-kernel))) 32 | 33 | (defvar *kernel-manager* (make-kernel-manager)) 34 | 35 | (defun kernel-manager-define-function (manager name args body) 36 | ;; Check reserved arguments not used. 37 | (unless (not (member 'i args)) 38 | (error "The argument I is reserved.")) 39 | (unless (not (member 'n args)) 40 | (error "The argument N is reserved.")) 41 | (let ((args1 (append '(i n) args))) 42 | ;; Compile and define kernel function. 43 | (let ((kernel (kernel-manager-kernel manager))) 44 | ;; Compile kernel function. 45 | (multiple-value-bind (lisp-name ftype lisp-form) 46 | (compile-kernel-function :lisp name args1 body kernel) 47 | (multiple-value-bind (caller-name cuda-name _ cuda-form) 48 | (compile-kernel-function :cuda name args1 body kernel) 49 | (declare (ignore _)) 50 | ;; Define kernel function to kernel. 51 | (kernel-define-function kernel name lisp-name cuda-name 52 | ftype args1 body) 53 | ;; Return compiled form. 54 | (values lisp-name lisp-form caller-name cuda-form 55 | (include-vector-type-p ftype))))))) 56 | 57 | (defun include-vector-type-p (type) 58 | (some #'vector-type-p (function-arg-types type))) 59 | 60 | (defun kernel-manager-define-macro (manager name args body) 61 | (let ((kernel (kernel-manager-kernel manager))) 62 | (kernel-define-macro kernel name args body))) 63 | 64 | (defun kernel-manager-expand-macro-1 (manager form) 65 | (let ((kernel (kernel-manager-kernel manager))) 66 | (if (listp form) 67 | (destructuring-bind (name . args) form 68 | (if (and (avm-symbol-p name) 69 | (kernel-macro-exists-p kernel name)) 70 | (let ((expander (kernel-macro-expander kernel name))) 71 | (values (funcall expander args) t)) 72 | (values form nil))) 73 | (values form nil)))) 74 | 75 | (defun kernel-manager-expand-macro (manager form) 76 | (labels ((aux (form expanded-p) 77 | (multiple-value-bind (form1 newly-expanded-p) 78 | (kernel-manager-expand-macro-1 manager form) 79 | (if newly-expanded-p 80 | (aux form1 t) 81 | (values form1 expanded-p))))) 82 | (aux form nil))) 83 | -------------------------------------------------------------------------------- /src/api/macro.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.api.macro 8 | (:use :cl 9 | :avm 10 | :avm.api.kernel-manager) 11 | (:import-from :alexandria 12 | :with-gensyms) 13 | (:export :expand-macro-1 14 | :expand-macro 15 | )) 16 | (in-package :avm.api.macro) 17 | 18 | 19 | ;; 20 | ;; EXPAND-MACRO 21 | 22 | (defun expand-macro-1 (form &optional (manager *kernel-manager*)) 23 | (kernel-manager-expand-macro-1 manager form)) 24 | 25 | (defun expand-macro (form &optional (manager *kernel-manager*)) 26 | (kernel-manager-expand-macro manager form)) 27 | 28 | 29 | ;; 30 | ;; PROGN 31 | 32 | (defun progn-form (body) 33 | (if (and (listp body) 34 | (not (null body))) 35 | (destructuring-bind (form . body1) body 36 | (if body1 37 | (with-gensyms (var) 38 | `(let ((,var ,form)) 39 | (progn ,@body1))) 40 | form)) 41 | (error "The value ~S is an invalid form." `(progn ,@body)))) 42 | 43 | (defkernel-macro progn (&body body) 44 | (progn-form body)) 45 | 46 | 47 | ;; 48 | ;; LET* 49 | 50 | (defun let*-form (bindings body) 51 | (if bindings 52 | (destructuring-bind (binding . bindings1) bindings 53 | `(let (,binding) 54 | (let* ,bindings1 55 | ,@body))) 56 | `(progn ,@body))) 57 | 58 | (defkernel-macro let* (bindings &body body) 59 | (let*-form bindings body)) 60 | -------------------------------------------------------------------------------- /src/avm.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm 8 | (:use :cl) 9 | (:export ;; Types 10 | :bool 11 | :int :int2 :int3 :int4 12 | :float :float2 :float3 :float4 13 | :double :double2 :double3 :double4 14 | :int-array :int2-array :int3-array :int4-array 15 | :float-array :float2-array :float3-array :float4-array 16 | :double-array :double2-array :double3-array :double4-array 17 | ;; Vector type accessors 18 | :int2-x :int2-y 19 | :int3-x :int3-y :int3-z 20 | :int4-x :int4-y :int4-z :int4-w 21 | :float2-x :float2-y 22 | :float3-x :float3-y :float3-z 23 | :float4-x :float4-y :float4-z :float4-w 24 | :double2-x :double2-y 25 | :double3-x :double3-y :double3-z 26 | :double4-x :double4-y :double4-z :double4-w 27 | ;; Vector algebra 28 | :*. :.* :/. :dot 29 | ;; Mathematical functions 30 | :rsqrt 31 | ;; Built-in variables 32 | :i :n 33 | ;; Special variables 34 | :*kernel-manager* 35 | ;; DEFKERNEL 36 | :defkernel 37 | :*number-of-threads* 38 | :*compile-on-runtime* 39 | :defkernel-macro 40 | ;; Macro 41 | :expand-macro-1 42 | :expand-macro 43 | ;; CUDA 44 | :with-cuda 45 | :*use-cuda-p* 46 | :synchronize 47 | ;; Arrays 48 | :avm-array 49 | :array-p 50 | :alloc-array 51 | :free-array 52 | :with-array 53 | :with-arrays 54 | :array-aref 55 | :array-size 56 | )) 57 | (in-package :avm) 58 | 59 | ;; blah blah blah. 60 | -------------------------------------------------------------------------------- /src/lang/appenv.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.appenv 8 | (:use :cl 9 | :avm.lang.symbol 10 | :avm.lang.type 11 | :avm.lang.unienv) 12 | (:export :empty-appenv 13 | :extend-appenv 14 | :query-appenv 15 | :subst-appenv)) 16 | (in-package :avm.lang.appenv) 17 | 18 | 19 | ;; 20 | ;; Function application environment 21 | 22 | (defun empty-appenv () 23 | nil) 24 | 25 | (defun extend-appenv (form type aenv) 26 | (check-type type (or avm-type function-type)) 27 | (acons form type aenv)) 28 | 29 | (defun query-appenv (form aenv) 30 | (or (cdr (assoc form aenv)) 31 | (error "The function application ~S not found." form))) 32 | 33 | (defun subst-appenv (uenv aenv) 34 | (loop for (form . type) in aenv 35 | collect 36 | (if (avm-type-p type) 37 | (let ((type1 (query-unienv type uenv))) 38 | (cons form type1)) 39 | (let ((ftype1 (loop for type1 in type 40 | collect (query-unienv type1 uenv)))) 41 | (cons form ftype1))))) 42 | -------------------------------------------------------------------------------- /src/lang/binarize.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.binarize 8 | (:use :cl 9 | :avm 10 | :avm.lang.built-in) 11 | (:export :binarize)) 12 | (in-package :avm.lang.binarize) 13 | 14 | 15 | ;; 16 | ;; Binarize 17 | 18 | (defun binarize (form) 19 | (if (atom form) 20 | form 21 | (if (and (nthcdr 3 form) 22 | (built-in-arithmetic-p (car form))) 23 | (if (built-in-arithmetic-left-assoc-p (car form)) 24 | (destructuring-bind (op a1 a2 . rest) form 25 | (binarize `(,op (,op ,(binarize a1) ,(binarize a2)) ,@rest))) 26 | (destructuring-bind (op . args) form 27 | (destructuring-bind (a2 a1 . rest) (reverse args) 28 | (binarize `(,op ,@(reverse rest) 29 | (,op ,(binarize a1) ,(binarize a2))))))) 30 | (mapcar #'binarize form)))) 31 | -------------------------------------------------------------------------------- /src/lang/built-in.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.built-in 8 | (:use :cl 9 | :avm 10 | :avm.lang.type) 11 | (:export :built-in-functions 12 | :built-in-arithmetic-p 13 | :built-in-arithmetic-left-assoc-p 14 | :built-in-arithmetic-right-assoc-p 15 | :built-in-exists-p 16 | :built-in-type-scheme 17 | :built-in-argc 18 | :built-in-operator 19 | )) 20 | (in-package :avm.lang.built-in) 21 | 22 | 23 | ;; 24 | ;; Built-in functions 25 | 26 | (defgeneric built-in-functions (engine)) 27 | 28 | (defun built-in-arithmetic-p (name) 29 | (and (member name '(+ - * / *. .* /.)) 30 | t)) 31 | 32 | (defun built-in-arithmetic-left-assoc-p (name) 33 | (and (built-in-arithmetic-p name) 34 | (not (built-in-arithmetic-right-assoc-p name)))) 35 | 36 | (defun built-in-arithmetic-right-assoc-p (name) 37 | (eq name '.*)) 38 | 39 | (defun built-in-exists-p (name) 40 | (and (assoc name (built-in-functions :lisp)) 41 | t)) 42 | 43 | (defun built-in-type-scheme (name) 44 | (cons :type-scheme 45 | (or (cadr (assoc name (built-in-functions :lisp))) 46 | (error "The function ~S is not defined." name)))) 47 | 48 | (defun built-in-argc (name) 49 | (- (length (built-in-type-scheme name)) 2)) 50 | 51 | (defun built-in-candidates (engine name) 52 | (or (caddr (assoc name (built-in-functions engine))) 53 | (error "The function ~S is not defined." name))) 54 | 55 | (defun built-in-elected (engine name function-type) 56 | (or (assoc function-type (built-in-candidates engine name) :test #'equal) 57 | (error "The function ~S is not defined." name))) 58 | 59 | (defun built-in-operator (engine name function-type) 60 | (cadr (built-in-elected engine name function-type))) 61 | -------------------------------------------------------------------------------- /src/lang/compiler/cuda/built-in.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.compiler.cuda.built-in 8 | (:use :cl 9 | :avm 10 | :avm.lang.built-in) 11 | (:export)) 12 | (in-package :avm.lang.compiler.cuda.built-in) 13 | 14 | 15 | (defmethod built-in-functions ((engine (eql :cuda))) 16 | '((+ (a a a) 17 | (((int int int) +) 18 | (((:vector int 2) (:vector int 2) (:vector int 2)) +) 19 | (((:vector int 3) (:vector int 3) (:vector int 3)) +) 20 | (((:vector int 4) (:vector int 4) (:vector int 4)) +) 21 | ((float float float) +) 22 | (((:vector float 2) (:vector float 2) (:vector float 2)) +) 23 | (((:vector float 3) (:vector float 3) (:vector float 3)) +) 24 | (((:vector float 4) (:vector float 4) (:vector float 4)) +) 25 | ((double double double) +) 26 | (((:vector double 2) (:vector double 2) (:vector double 2)) +) 27 | (((:vector double 3) (:vector double 3) (:vector double 3)) +) 28 | (((:vector double 4) (:vector double 4) (:vector double 4)) +) 29 | )) 30 | (- (a a a) 31 | (((int int int) -) 32 | (((:vector int 2) (:vector int 2) (:vector int 2)) -) 33 | (((:vector int 3) (:vector int 3) (:vector int 3)) -) 34 | (((:vector int 4) (:vector int 4) (:vector int 4)) -) 35 | ((float float float) -) 36 | (((:vector float 2) (:vector float 2) (:vector float 2)) -) 37 | (((:vector float 3) (:vector float 3) (:vector float 3)) -) 38 | (((:vector float 4) (:vector float 4) (:vector float 4)) -) 39 | ((double double double) -) 40 | (((:vector double 2) (:vector double 2) (:vector double 2)) -) 41 | (((:vector double 3) (:vector double 3) (:vector double 3)) -) 42 | (((:vector double 4) (:vector double 4) (:vector double 4)) -) 43 | )) 44 | (* (a a a) (((int int int) *) 45 | ((float float float) *) 46 | ((double double double) *))) 47 | (/ (a a a) (((int int int) /) 48 | ((float float float) /) 49 | ((double double double) /))) 50 | (*. ((:vector a b) a (:vector a b)) 51 | ((((:vector int 2) int (:vector int 2)) *) 52 | (((:vector int 3) int (:vector int 3)) *) 53 | (((:vector int 4) int (:vector int 4)) *) 54 | (((:vector float 2) float (:vector float 2)) *) 55 | (((:vector float 3) float (:vector float 3)) *) 56 | (((:vector float 4) float (:vector float 4)) *) 57 | (((:vector double 2) double (:vector double 2)) *) 58 | (((:vector double 3) double (:vector double 3)) *) 59 | (((:vector double 4) double (:vector double 4)) *))) 60 | (.* (a (:vector a b) (:vector a b)) 61 | (((int (:vector int 2) (:vector int 2)) *) 62 | ((int (:vector int 3) (:vector int 3)) *) 63 | ((int (:vector int 4) (:vector int 4)) *) 64 | ((float (:vector float 2) (:vector float 2)) *) 65 | ((float (:vector float 3) (:vector float 3)) *) 66 | ((float (:vector float 4) (:vector float 4)) *) 67 | ((double (:vector double 2) (:vector double 2)) *) 68 | ((double (:vector double 3) (:vector double 3)) *) 69 | ((double (:vector double 4) (:vector double 4)) *))) 70 | (/. ((:vector a b) a (:vector a b)) 71 | (;(((:vector int 2) int (:vector int 2)) /) 72 | ;(((:vector int 3) int (:vector int 3)) /) 73 | ;(((:vector int 4) int (:vector int 4)) /) 74 | (((:vector float 2) float (:vector float 2)) /) 75 | (((:vector float 3) float (:vector float 3)) /) 76 | (((:vector float 4) float (:vector float 4)) /) 77 | (((:vector double 2) double (:vector double 2)) /) 78 | (((:vector double 3) double (:vector double 3)) /) 79 | (((:vector double 4) double (:vector double 4)) /))) 80 | (dot ((:vector a b) (:vector a b) a) 81 | ((((:vector int 2) (:vector int 2) int) cl-cuda:dot) 82 | (((:vector int 3) (:vector int 3) int) cl-cuda:dot) 83 | (((:vector int 4) (:vector int 4) int) cl-cuda:dot) 84 | (((:vector float 2) (:vector float 2) float) cl-cuda:dot) 85 | (((:vector float 3) (:vector float 3) float) cl-cuda:dot) 86 | (((:vector float 4) (:vector float 4) float) cl-cuda:dot) 87 | (((:vector double 2) (:vector double 2) double) cl-cuda:dot) 88 | (((:vector double 3) (:vector double 3) double) cl-cuda:dot) 89 | (((:vector double 4) (:vector double 4) double) cl-cuda:dot))) 90 | (< (a a bool) (((int int bool) <) 91 | ((float float bool) <) 92 | ((doublet double bool) <))) 93 | (> (a a bool) (((int int bool) >) 94 | ((float float bool) >) 95 | ((double double bool) >))) 96 | ;; (int2 (int int (:vector int 2)) 97 | ;; (((int int (:vector int 2)) cl-cuda:int2))) 98 | ;; (int3 (int int int (:vector int 3)) 99 | ;; (((int int int (:vector int 3)) cl-cuda:int3))) 100 | ;; (int4 (int int int int (:vector int 4)) 101 | ;; (((int int int int (:vector int 4)) cl-cuda:int4))) 102 | ;; (float2 (float float (:vector float 2)) 103 | ;; (((float float (:vector float 2)) cl-cuda:float2))) 104 | (float3 (float float float (:vector float 3)) 105 | (((float float float (:vector float 3)) cl-cuda:float3))) 106 | (float4 (float float float float (:vector float 4)) 107 | (((float float float float (:vector float 4)) cl-cuda:float4))) 108 | ;; (double2 (double double (:vector double 2)) 109 | ;; (((double double (:vector double 2)) cl-cuda:double2))) 110 | (double3 (double double double (:vector double 3)) 111 | (((double double double (:vector double 3)) cl-cuda:double3))) 112 | (double4 (double double double double (:vector double 4)) 113 | (((double double double double (:vector double 4)) 114 | cl-cuda:double4))) 115 | ;; (int2-x ((:vector int 2) int) 116 | ;; ((((:vector int 2) int) cl-cuda:int2-x))) 117 | ;; (int2-y ((:vector int 2) int) 118 | ;; ((((:vector int 2) int) cl-cuda:int2-y))) 119 | ;; (int3-x ((:vector int 3) int) 120 | ;; ((((:vector int 3) int) cl-cuda:int3-x))) 121 | ;; (int3-y ((:vector int 3) int) 122 | ;; ((((:vector int 3) int) cl-cuda:int3-y))) 123 | ;; (int3-z ((:vector int 3) int) 124 | ;; ((((:vector int 3) int) cl-cuda:int3-z))) 125 | ;; (int4-x ((:vector int 4) int) 126 | ;; ((((:vector int 4) int) cl-cuda:int4-x))) 127 | ;; (int4-y ((:vector int 4) int) 128 | ;; ((((:vector int 4) int) cl-cuda:int4-y))) 129 | ;; (int4-z ((:vector int 4) int) 130 | ;; ((((:vector int 4) int) cl-cuda:int4-z))) 131 | ;; (int4-w ((:vector int 4) int) 132 | ;; ((((:vector int 4) int) cl-cuda:int4-w))) 133 | ;; (float2-x ((:vector float 2) float) 134 | ;; ((((:vector float 2) float) cl-cuda:float2-x))) 135 | ;; (float2-y ((:vector float 2) float) 136 | ;; ((((:vector float 2) float) cl-cuda:float2-y))) 137 | (float3-x ((:vector float 3) float) 138 | ((((:vector float 3) float) cl-cuda:float3-x))) 139 | (float3-y ((:vector float 3) float) 140 | ((((:vector float 3) float) cl-cuda:float3-y))) 141 | (float3-z ((:vector float 3) float) 142 | ((((:vector float 3) float) cl-cuda:float3-z))) 143 | (float4-x ((:vector float 4) float) 144 | ((((:vector float 4) float) cl-cuda:float4-x))) 145 | (float4-y ((:vector float 4) float) 146 | ((((:vector float 4) float) cl-cuda:float4-y))) 147 | (float4-z ((:vector float 4) float) 148 | ((((:vector float 4) float) cl-cuda:float4-z))) 149 | (float4-w ((:vector float 4) float) 150 | ((((:vector float 4) float) cl-cuda:float4-w))) 151 | ;; (double2-x ((:vector double 2) double) 152 | ;; ((((:vector double 2) double) cl-cuda:double2-x))) 153 | ;; (double2-y ((:vector double 2) double) 154 | ;; ((((:vector double 2) double) cl-cuda:double2-y))) 155 | (double3-x ((:vector double 3) double) 156 | ((((:vector double 3) double) cl-cuda:double3-x))) 157 | (double3-y ((:vector double 3) double) 158 | ((((:vector double 3) double) cl-cuda:double3-y))) 159 | (double3-z ((:vector double 3) double) 160 | ((((:vector double 3) double) cl-cuda:double3-z))) 161 | (double4-x ((:vector double 4) double) 162 | ((((:vector double 4) double) cl-cuda:double4-x))) 163 | (double4-y ((:vector double 4) double) 164 | ((((:vector double 4) double) cl-cuda:double4-y))) 165 | (double4-z ((:vector double 4) double) 166 | ((((:vector double 4) double) cl-cuda:double4-z))) 167 | (double4-w ((:vector double 4) double) 168 | ((((:vector double 4) double) cl-cuda:double4-w))) 169 | (aref ((:array a) int a) 170 | ((((:array int) int int) aref) 171 | (((:array (:vector int 2)) int (:vector int 2)) aref) 172 | (((:array (:vector int 3)) int (:vector int 3)) aref) 173 | (((:array (:vector int 4)) int (:vector int 4)) aref) 174 | (((:array float) int float) aref) 175 | (((:array (:vector float 2)) int (:vector float 2)) aref) 176 | (((:array (:vector float 3)) int (:vector float 3)) aref) 177 | (((:array (:vector float 4)) int (:vector float 4)) aref) 178 | (((:array double) int double) aref) 179 | (((:array (:vector double 2)) int (:vector double 2)) aref) 180 | (((:array (:vector double 3)) int (:vector double 3)) aref) 181 | (((:array (:vector double 4)) int (:vector double 4)) aref) 182 | )) 183 | (mod (int int int) (((int int int) cl-cuda::mod))) 184 | (float (int float) (((int float) float))) 185 | (double (int double) (((int double) double))) 186 | ;; (coerce (a b) (((int float) int->float) 187 | ;; ((int double) int->double) 188 | ;; ((float double) float->double))) 189 | ;; Mathematical functions. 190 | (rsqrt (a a) (((float float) cl-cuda:rsqrt) 191 | ((double double) cl-cuda:rsqrt))) 192 | ;; (norm ((:vector a _) a) 193 | ;; (;(((:vector int 2) int) cl-cuda:norm) 194 | ;; ;(((:vector int 3) int) cl-cuda:norm) 195 | ;; ;(((:vector int 4) int) cl-cuda:norm) 196 | ;; (((:vector float 2) float) cl-cuda:norm) 197 | ;; (((:vector float 3) float) cl-cuda:norm) 198 | ;; (((:vector float 4) float) cl-cuda:norm) 199 | ;; (((:vector double 2) double) cl-cuda:norm) 200 | ;; (((:vector double 3) double) cl-cuda:norm) 201 | ;; (((:vector double 4) double) cl-cuda:norm))) 202 | )) 203 | -------------------------------------------------------------------------------- /src/lang/compiler/cuda/compile-type.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.compiler.cuda.compile-type 8 | (:use :cl 9 | :avm) 10 | (:export :compile-type)) 11 | (in-package :avm.lang.compiler.cuda.compile-type) 12 | 13 | 14 | (defun compile-type (type) 15 | ;; TODO: use abstract type 16 | (cl-pattern:match type 17 | ('bool 'cl-cuda:bool) 18 | ('int 'cl-cuda:int) 19 | ('float 'cl-cuda:float) 20 | ('double 'cl-cuda:double) 21 | ((:vector base-type size) 22 | (intern (format nil "~A~A" base-type size) (find-package :cl-cuda))) 23 | ((:array type1) 24 | (cl-pattern:match type1 25 | ('int 'cl-cuda:int*) 26 | ('float 'cl-cuda:float*) 27 | ('double 'cl-cuda:double*) 28 | ((:vector base-type size) 29 | (intern (format nil "~A~A*" base-type size) (find-package :cl-cuda))) 30 | (_ (error "Must not be reached.")))) 31 | (_ (error "Must not be reached.")))) 32 | -------------------------------------------------------------------------------- /src/lang/compiler/cuda/compile.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.compiler.cuda.compile 8 | (:use :cl 9 | :avm 10 | :avm.lang.type 11 | :avm.lang.syntax 12 | :avm.lang.built-in 13 | :avm.lang.appenv 14 | :avm.lang.funenv 15 | :avm.lang.compiler.cuda.compile-type 16 | ) 17 | (:export :compile-function 18 | :*genname-counter*)) 19 | (in-package :avm.lang.compiler.cuda.compile) 20 | 21 | 22 | ;; 23 | ;; Genname 24 | 25 | (defvar *genname-counter* 0) 26 | 27 | (defun genname (name) 28 | (prog1 (intern (format nil "%~A~A" name *genname-counter*)) 29 | (incf *genname-counter*))) 30 | 31 | 32 | ;; 33 | ;; Compile 34 | 35 | (defun compile-function (name ftype args body aenv fenv funcs 36 | &key entry-p rec-p) 37 | (assert (not (and entry-p (not rec-p)))) 38 | (let* ((cuda-name (compile-name name entry-p nil)) 39 | (fenv1 (if rec-p 40 | (extend-funenv-function name cuda-name ftype args fenv) 41 | fenv))) 42 | (multiple-value-bind (body1 funcs1) 43 | (compile-form body :tail aenv fenv1 funcs) 44 | (let ((func (%compile-function cuda-name ftype args body1))) 45 | (if (not entry-p) 46 | (values cuda-name (cons func funcs1)) 47 | (multiple-value-bind (caller-name caller-func) 48 | (%compile-caller-function name cuda-name ftype args) 49 | (values caller-name 50 | cuda-name 51 | (cons caller-func 52 | (cons func funcs1))))))))) 53 | 54 | (defun %compile-function (cuda-name ftype args body) 55 | (let ((args1 (loop for arg in args 56 | for type in (function-arg-types ftype) 57 | for type1 = (compile-type type) 58 | collect (list arg type1))) 59 | (return-type (compile-type 60 | (function-return-type ftype)))) 61 | `(cl-cuda:defkernel ,cuda-name (,return-type ,args1) 62 | ,body))) 63 | 64 | (defun %compile-caller-function (name cuda-name ftype args) 65 | (let ((caller-name (compile-name name t t)) 66 | (args1 (loop for arg in args 67 | for type in (function-arg-types ftype) 68 | for type1 = (compile-type type) 69 | collect (list arg type1)))) 70 | (let ((func `(cl-cuda:defkernel ,caller-name (cl-cuda:void ,(cdr args1)) 71 | (let ((i (+ (* cl-cuda:block-dim-x cl-cuda:block-idx-x) 72 | cl-cuda:thread-idx-x))) 73 | (when (< i n) 74 | (,cuda-name ,@args)))))) 75 | (values caller-name func)))) 76 | 77 | (defun compile-name (name entry-p caller-p) 78 | (assert (not (and (not entry-p) caller-p))) 79 | (if entry-p 80 | (let ((symbol-name (symbol-name name)) 81 | (symbol-package (symbol-package name))) 82 | (intern (format nil "%~@[CALL-~*~]CUDA-~A" caller-p symbol-name) 83 | symbol-package)) 84 | (genname name))) 85 | 86 | (defun compile-form (form dest aenv fenv funcs) 87 | (cond 88 | ((literal-p form) (compile-literal form dest aenv fenv funcs)) 89 | ((reference-p form) (compile-reference form dest aenv fenv funcs)) 90 | ((accessor-p form) (compile-accessor form dest aenv fenv funcs)) 91 | ((the-p form) (compile-the form dest aenv fenv funcs)) 92 | ((if-p form) (compile-if form dest aenv fenv funcs)) 93 | ((let-p form) (compile-let form dest aenv fenv funcs)) 94 | ((flet-p form) (compile-flet form dest aenv fenv funcs)) 95 | ((labels-p form) (compile-labels form dest aenv fenv funcs)) 96 | ((setf-p form) (compile-setf form dest aenv fenv funcs)) 97 | ((apply-p form) (compile-apply form dest aenv fenv funcs)) 98 | (t (error "The value ~S is an invalid form." form)))) 99 | 100 | (defun compile-literal (form dest aenv fenv funcs) 101 | (declare (ignore aenv fenv)) 102 | (cl-pattern:match dest 103 | (:tail (values `(return ,form) funcs)) 104 | ((:non-tail var) (values `(set ,var ,form) funcs)) 105 | (_ (error "The value ~S is an invalid destination." dest)))) 106 | 107 | (defun compile-reference (form dest aenv fenv funcs) 108 | (declare (ignore aenv fenv)) 109 | (cl-pattern:match dest 110 | (:tail (values `(return ,form) funcs)) 111 | ((:non-tail var) (values `(set ,var ,form) funcs)) 112 | (_ (error "The value ~S is an invalid destination." dest)))) 113 | 114 | (defun compile-accessor (form dest aenv fenv funcs) 115 | (compile-apply form dest aenv fenv funcs)) 116 | 117 | (defun compile-the (form dest aenv fenv funcs) 118 | (let ((value (the-value form))) 119 | (compile-form value dest aenv fenv funcs))) 120 | 121 | (defun compile-if (form dest aenv fenv funcs) 122 | ;; Assuming K-normalized. 123 | (let ((test-form (if-test-form form)) 124 | (then-form (if-then-form form)) 125 | (else-form (if-else-form form))) 126 | (multiple-value-bind (then-form1 funcs1) 127 | (compile-form then-form dest aenv fenv funcs) 128 | (multiple-value-bind (else-form1 funcs2) 129 | (compile-form else-form dest aenv fenv funcs1) 130 | (values `(if ,test-form ,then-form1 ,else-form1) funcs2))))) 131 | 132 | (defun compile-let (form dest aenv fenv funcs) 133 | (let ((bindings (let-bindings form)) 134 | (body (let-body form))) 135 | (%compile-let bindings body dest aenv fenv funcs))) 136 | 137 | (defun type-zero (type) 138 | (cl-pattern:match type 139 | ('bool nil) 140 | ('int 0) 141 | ('float 0.0) 142 | ('double 0.0d0) 143 | ;; ((:vector 'int 2) '(cl-cuda:int2 0 0)) 144 | ;; ((:vector 'int 3) '(cl-cuda:int3 0 0 0)) 145 | ;; ((:vector 'int 4) '(cl-cuda:int4 0 0 0 0)) 146 | ;; ((:vector 'float 2) '(cl-cuda:float2 0.0 0.0)) 147 | ((:vector 'float 3) '(cl-cuda:float3 0.0 0.0 0.0)) 148 | ((:vector 'float 4) '(cl-cuda:float4 0.0 0.0 0.0 0.0)) 149 | ;; ((:vector 'double 2) '(cl-cuda:double2 0.0d0 0.0d0)) 150 | ((:vector 'double 3) '(cl-cuda:double3 0.0d0 0.0d0 0.0d0)) 151 | ((:vector 'double 4) '(cl-cuda:double4 0.0d0 0.0d0 0.0d0 0.0d0)) 152 | (_ (error "The value ~S is an invalid type." type)))) 153 | 154 | (defun %compile-let (bindings body dest aenv fenv funcs) 155 | (if bindings 156 | (destructuring-bind ((var value) . bindings1) bindings 157 | (multiple-value-bind (value1 funcs1) 158 | (compile-form value `(:non-tail ,var) aenv fenv funcs) 159 | (multiple-value-bind (body1 funcs2) 160 | (%compile-let bindings1 body dest aenv fenv funcs1) 161 | (let ((type (query-appenv (car bindings) aenv))) 162 | (values `(let ((,var ,(type-zero type))) 163 | ,value1 164 | ,body1) 165 | funcs2))))) 166 | (compile-form body dest aenv fenv funcs))) 167 | 168 | (defun compile-flet (form dest aenv fenv funcs) 169 | (let ((bindings (flet-bindings form)) 170 | (body (flet-body form))) 171 | (%compile-flet bindings body dest nil aenv fenv fenv funcs))) 172 | 173 | (defun %compile-flet (bindings body dest rec-p aenv fenv fenv1 funcs) 174 | (if bindings 175 | (destructuring-bind ((name args form) . bindings1) bindings 176 | (let ((ftype (query-appenv (car bindings) aenv))) 177 | (multiple-value-bind (name1 funcs1) 178 | (compile-function name ftype args form aenv fenv funcs 179 | :entry-p nil :rec-p rec-p) 180 | (let ((fenv2 (extend-funenv-function name name1 ftype args fenv1))) 181 | (%compile-flet bindings1 body dest rec-p 182 | aenv fenv fenv2 funcs1))))) 183 | (compile-form body dest aenv fenv1 funcs))) 184 | 185 | (defun compile-labels (form dest aenv fenv funcs) 186 | (let ((bindings (labels-bindings form)) 187 | (body (labels-body form))) 188 | (%compile-flet bindings body dest t aenv fenv fenv funcs))) 189 | 190 | (defun compile-setf (form dest aenv fenv funcs) 191 | ;; Assuming K-normalized. 192 | (let ((place (setf-place form)) 193 | (value (setf-value form))) 194 | (multiple-value-bind (value1 funcs1) 195 | (compile-form value dest aenv fenv funcs) 196 | (values `(progn 197 | (set ,place ,value) 198 | ,value1) 199 | funcs1)))) 200 | 201 | (defun compile-apply (form dest aenv fenv funcs) 202 | ;; Assuming K-normalized. 203 | (let ((operator (apply-operator form)) 204 | (operands (apply-operands form))) 205 | (let ((argc (if (built-in-exists-p operator) 206 | (built-in-argc operator) 207 | (funenv-function-argc operator fenv)))) 208 | (unless (= argc (length operands)) 209 | (error "Invalid number of arguments: ~S" (length operands)))) 210 | (let ((operator1 (if (built-in-exists-p operator) 211 | (built-in-operator :cuda operator 212 | (query-appenv form aenv)) 213 | (funenv-function-name1 operator fenv)))) 214 | (cl-pattern:match dest 215 | (:tail 216 | (values `(return (,operator1 ,@operands)) funcs)) 217 | ((:non-tail var) 218 | (values `(set ,var (,operator1 ,@operands)) funcs)) 219 | (_ (error "The value ~S is an invalid destination." dest)))))) 220 | -------------------------------------------------------------------------------- /src/lang/compiler/cuda/k-normal.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.compiler.cuda.k-normal 8 | (:use :cl 9 | :avm 10 | :avm.lang.syntax) 11 | (:export :k-normal 12 | :*gentmp-counter*)) 13 | (in-package :avm.lang.compiler.cuda.k-normal) 14 | 15 | 16 | ;; 17 | ;; Gentmp 18 | 19 | (defvar *gentmp-counter* 0) 20 | 21 | (defun gentmp () 22 | (prog1 (intern (format nil "T~A" *gentmp-counter*)) 23 | (incf *gentmp-counter*))) 24 | 25 | 26 | ;; 27 | ;; K-normalization 28 | 29 | (defun k-normal (form) 30 | (cond 31 | ((literal-p form) (k-normal-literal form)) 32 | ((reference-p form) (k-normal-reference form)) 33 | ((accessor-p form) (k-normal-accessor form)) 34 | ((the-p form) (k-normal-the form)) 35 | ((if-p form) (k-normal-if form)) 36 | ((let-p form) (k-normal-let form)) 37 | ((flet-p form) (k-normal-flet form)) 38 | ((labels-p form) (k-normal-labels form)) 39 | ((setf-p form) (k-normal-setf form)) 40 | ((apply-p form) (k-normal-apply form)) 41 | (t (error "The value ~S is an invalid form." form)))) 42 | 43 | (defun k-normal-literal (form) 44 | form) 45 | 46 | (defun k-normal-reference (form) 47 | form) 48 | 49 | (defun k-normal-accessor (form) 50 | (k-normal-apply form)) 51 | 52 | (defun k-normal-the (form) 53 | (let ((type (the-type form)) 54 | (value (the-value form))) 55 | (if (or (literal-p value) (reference-p value)) 56 | `(the ,type ,value) 57 | (let ((tmp (gentmp)) 58 | (value1 (k-normal value))) 59 | `(let ((,tmp ,value1)) 60 | (the ,type ,tmp)))))) 61 | 62 | (defun k-normal-if (form) 63 | (let ((test-form (if-test-form form)) 64 | (then-form (if-then-form form)) 65 | (else-form (if-else-form form))) 66 | (let ((tmp (gentmp)) 67 | (test-form1 (k-normal test-form)) 68 | (then-form1 (k-normal then-form)) 69 | (else-form1 (k-normal else-form))) 70 | (if (or (literal-p test-form) (reference-p test-form)) 71 | `(if ,test-form ,then-form1 ,else-form1) 72 | `(let ((,tmp ,test-form1)) 73 | (if ,tmp ,then-form1 ,else-form1)))))) 74 | 75 | (defun k-normal-let (form) 76 | (flet ((aux (binding) 77 | (destructuring-bind (var value) binding 78 | (let ((value1 (k-normal value))) 79 | `(,var ,value1))))) 80 | (let ((bindings (let-bindings form)) 81 | (body (let-body form))) 82 | (let ((bindings1 (mapcar #'aux bindings)) 83 | (body1 (k-normal body))) 84 | `(let ,bindings1 ,body1))))) 85 | 86 | (defun k-normal-flet (form) 87 | (let ((bindings (flet-bindings form)) 88 | (body (flet-body form))) 89 | (%k-normal-flet 'flet bindings body))) 90 | 91 | (defun %k-normal-flet (op bindings body) 92 | (flet ((aux (binding) 93 | (destructuring-bind (name args body) binding 94 | (let ((body1 (k-normal body))) 95 | `(,name ,args ,body1))))) 96 | (let ((bindings1 (mapcar #'aux bindings)) 97 | (body1 (k-normal body))) 98 | `(,op ,bindings1 ,body1)))) 99 | 100 | (defun k-normal-labels (form) 101 | (let ((bindings (labels-bindings form)) 102 | (body (labels-body form))) 103 | (%k-normal-flet 'labels bindings body))) 104 | 105 | (defun k-normal-setf (form) 106 | (let ((place (setf-place form)) 107 | (value (setf-value form))) 108 | (multiple-value-bind (fn place1) (k-normal-place place) 109 | (if (or (literal-p value) 110 | (reference-p value)) 111 | (funcall fn `(setf ,place1 ,value)) 112 | (let ((tmp (gentmp)) 113 | (value1 (k-normal value))) 114 | `(let ((,tmp ,value1)) 115 | ,(funcall fn `(setf ,place1 ,tmp)))))))) 116 | 117 | (defun k-normal-place (place) 118 | (cond 119 | ((reference-place-p place) (k-normal-reference-place place)) 120 | ((vector-place-p place) (k-normal-vector-place place)) 121 | ((array-place-p place) (k-normal-array-place place)) 122 | (t (error "Must not be reached.")))) 123 | 124 | (defun k-normal-reference-place (place) 125 | (values #'identity place)) 126 | 127 | (defun k-normal-vector-place (place) 128 | (let ((operator (vector-place-operator place)) 129 | (value (vector-place-value place))) 130 | (multiple-value-bind (fn value1) (k-normal-place value) 131 | (values fn `(,operator ,value1))))) 132 | 133 | (defun k-normal-array-place (place) 134 | (let ((value (array-place-value place)) 135 | (index (array-place-index place))) 136 | (multiple-value-bind (fn value1) (k-normal-place value) 137 | (if (or (literal-p index) 138 | (reference-p index)) 139 | (values fn `(aref ,value1 ,index)) 140 | (let ((tmp (gentmp)) 141 | (index1 (k-normal index))) 142 | (values #'(lambda (form) 143 | `(let ((,tmp ,index1)) 144 | ,(funcall fn form))) 145 | `(aref ,value1 ,tmp))))))) 146 | 147 | (defun k-normal-apply (form) 148 | (let ((operator (apply-operator form)) 149 | (operands (apply-operands form))) 150 | (%k-normal-apply operator operands nil))) 151 | 152 | (defun %k-normal-apply (operator operands tmps) 153 | (if operands 154 | (destructuring-bind (operand . operands1) operands 155 | (if (or (literal-p operand) (reference-p operand)) 156 | (%k-normal-apply operator operands1 (cons operand tmps)) 157 | (let ((tmp (gentmp)) 158 | (operand1 (k-normal operand))) 159 | `(let ((,tmp ,operand1)) 160 | ,(%k-normal-apply operator operands1 (cons tmp tmps)))))) 161 | `(,operator ,@(nreverse tmps)))) 162 | -------------------------------------------------------------------------------- /src/lang/compiler/cuda/lang.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.compiler.cuda.lang 8 | (:use :cl 9 | :avm 10 | :avm.lang 11 | :avm.lang.kernel 12 | :avm.lang.expand-macro 13 | :avm.lang.convert-implicit-progn 14 | :avm.lang.binarize 15 | :avm.lang.convert-functions 16 | :avm.lang.free-variable 17 | :avm.lang.typenv 18 | :avm.lang.unienv 19 | :avm.lang.funenv 20 | :avm.lang.appenv 21 | :avm.lang.infer 22 | :avm.lang.compiler.cuda.k-normal 23 | :avm.lang.compiler.cuda.compile 24 | ) 25 | (:shadowing-import-from :avm.lang.expand-macro 26 | :expand-macro)) 27 | (in-package :avm.lang.compiler.cuda.lang) 28 | 29 | 30 | (eval-when (:compile-toplevel :load-toplevel :execute) 31 | (setf (fdefinition 'kernel->vars) 32 | #'avm.lang.compiler.lisp.lang::kernel->vars) 33 | 34 | (setf (fdefinition 'kernel->typenv) 35 | #'avm.lang.compiler.lisp.lang::kernel->typenv) 36 | 37 | (setf (fdefinition '%extend-macros) 38 | #'avm.lang.compiler.lisp.lang::%extend-macros) 39 | 40 | (setf (fdefinition 'subst-ftype) 41 | #'avm.lang.compiler.lisp.lang::subst-ftype)) 42 | 43 | (defun %extend-functions (kernel funenv) 44 | (flet ((aux (funenv1 name) 45 | (let ((cuda-name (kernel-function-cuda-name kernel name)) 46 | (type (kernel-function-type kernel name)) 47 | (args (kernel-function-arguments kernel name))) 48 | (extend-funenv-function name cuda-name type args funenv1)))) 49 | (reduce #'aux (kernel-function-names kernel) 50 | :initial-value funenv))) 51 | 52 | (defun kernel->funenv (kernel) 53 | (%extend-macros kernel 54 | (%extend-functions kernel 55 | (empty-funenv)))) 56 | 57 | (defmethod compile-kernel-function ((engine (eql :cuda)) name args body kernel) 58 | (let* ((fenv (kernel->funenv kernel)) 59 | (body1 (convert-functions 60 | (binarize 61 | (convert-implicit-progn 62 | (expand-macro body fenv)))))) 63 | ;; Check free variable existence. 64 | (let ((vars (kernel->vars kernel))) 65 | (check-free-variable args body1 vars)) 66 | ;; K-normalization. 67 | (let ((body2 (k-normal body1))) 68 | ;; Type inference. 69 | (let ((tenv (kernel->typenv kernel)) 70 | (aenv (empty-appenv)) 71 | (uenv (empty-unienv))) 72 | (multiple-value-bind (ftype aenv1 uenv1) 73 | (infer-function name args body2 tenv aenv uenv fenv) 74 | ;; Compilation. 75 | (let ((aenv2 (subst-appenv uenv1 aenv1)) 76 | (ftype1 (subst-ftype uenv1 ftype))) 77 | (multiple-value-bind (caller-name cuda-name defkernels) 78 | (compile-function name ftype1 args body2 aenv2 fenv nil 79 | :entry-p t :rec-p t) 80 | (values caller-name cuda-name ftype1 81 | `(progn ,@(nreverse defkernels)))))))))) 82 | 83 | (defmethod compile-kernel-global (kernel name (engine (eql :cuda))) 84 | nil) 85 | 86 | (defmethod compile-kernel-constant (kernel name (engine (eql :cuda))) 87 | nil) 88 | -------------------------------------------------------------------------------- /src/lang/compiler/lisp/built-in.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.compiler.lisp.built-in 8 | (:use :cl 9 | :avm 10 | :avm.lang.data 11 | :avm.lang.built-in) 12 | (:export)) 13 | (in-package :avm.lang.compiler.lisp.built-in) 14 | 15 | 16 | (defmethod built-in-functions ((engine (eql :lisp))) 17 | '((+ (a a a) 18 | (((int int int) +) 19 | (((:vector int 2) (:vector int 2) (:vector int 2)) int2-add*) 20 | (((:vector int 3) (:vector int 3) (:vector int 3)) int3-add*) 21 | (((:vector int 4) (:vector int 4) (:vector int 4)) int4-add*) 22 | ((float float float) +) 23 | (((:vector float 2) (:vector float 2) (:vector float 2)) float2-add*) 24 | (((:vector float 3) (:vector float 3) (:vector float 3)) float3-add*) 25 | (((:vector float 4) (:vector float 4) (:vector float 4)) float4-add*) 26 | ((double double double) +) 27 | (((:vector double 2) (:vector double 2) (:vector double 2)) double2-add*) 28 | (((:vector double 3) (:vector double 3) (:vector double 3)) double3-add*) 29 | (((:vector double 4) (:vector double 4) (:vector double 4)) double4-add*) 30 | )) 31 | (- (a a a) 32 | (((int int int) -) 33 | (((:vector int 2) (:vector int 2) (:vector int 2)) int2-sub*) 34 | (((:vector int 3) (:vector int 3) (:vector int 3)) int3-sub*) 35 | (((:vector int 4) (:vector int 4) (:vector int 4)) int4-sub*) 36 | ((float float float) -) 37 | (((:vector float 2) (:vector float 2) (:vector float 2)) float2-sub*) 38 | (((:vector float 3) (:vector float 3) (:vector float 3)) float3-sub*) 39 | (((:vector float 4) (:vector float 4) (:vector float 4)) float4-sub*) 40 | ((double double double) -) 41 | (((:vector double 2) (:vector double 2) (:vector double 2)) double2-sub*) 42 | (((:vector double 3) (:vector double 3) (:vector double 3)) double3-sub*) 43 | (((:vector double 4) (:vector double 4) (:vector double 4)) double4-sub*) 44 | )) 45 | (* (a a a) (((int int int) *) 46 | ((float float float) *) 47 | ((double double double) *))) 48 | (/ (a a a) (((int int int) floor) 49 | ((float float float) /) 50 | ((double double double) /))) 51 | (*. ((:vector a b) a (:vector a b)) 52 | ((((:vector int 2) int (:vector int 2)) int2-scale*) 53 | (((:vector int 3) int (:vector int 3)) int3-scale*) 54 | (((:vector int 4) int (:vector int 4)) int4-scale*) 55 | (((:vector float 2) float (:vector float 2)) float2-scale*) 56 | (((:vector float 3) float (:vector float 3)) float3-scale*) 57 | (((:vector float 4) float (:vector float 4)) float4-scale*) 58 | (((:vector double 2) double (:vector double 2)) double2-scale*) 59 | (((:vector double 3) double (:vector double 3)) double3-scale*) 60 | (((:vector double 4) double (:vector double 4)) double4-scale*))) 61 | (.* (a (:vector a b) (:vector a b)) 62 | (((int (:vector int 2) (:vector int 2)) int2-%scale*) 63 | ((int (:vector int 3) (:vector int 3)) int3-%scale*) 64 | ((int (:vector int 4) (:vector int 4)) int4-%scale*) 65 | ((float (:vector float 2) (:vector float 2)) float2-%scale*) 66 | ((float (:vector float 3) (:vector float 3)) float3-%scale*) 67 | ((float (:vector float 4) (:vector float 4)) float4-%scale*) 68 | ((double (:vector double 2) (:vector double 2)) double2-%scale*) 69 | ((double (:vector double 3) (:vector double 3)) double3-%scale*) 70 | ((double (:vector double 4) (:vector double 4)) double4-%scale*))) 71 | (/. ((:vector a b) a (:vector a b)) 72 | (;(((:vector int 2) int (:vector int 2)) int2-scale-recip*) 73 | ;(((:vector int 3) int (:vector int 3)) int3-scale-recip*) 74 | ;(((:vector int 4) int (:vector int 4)) int4-scale-recip*) 75 | (((:vector float 2) float (:vector float 2)) float2-scale-recip*) 76 | (((:vector float 3) float (:vector float 3)) float3-scale-recip*) 77 | (((:vector float 4) float (:vector float 4)) float4-scale-recip*) 78 | (((:vector double 2) double (:vector double 2)) double2-scale-recip*) 79 | (((:vector double 3) double (:vector double 3)) double3-scale-recip*) 80 | (((:vector double 4) double (:vector double 4)) double4-scale-recip*))) 81 | (dot ((:vector a b) (:vector a b) a) 82 | ((((:vector int 2) (:vector int 2) int) int2-dot*) 83 | (((:vector int 3) (:vector int 3) int) int3-dot*) 84 | (((:vector int 4) (:vector int 4) int) int4-dot*) 85 | (((:vector float 2) (:vector float 2) float) float2-dot*) 86 | (((:vector float 3) (:vector float 3) float) float3-dot*) 87 | (((:vector float 4) (:vector float 4) float) float4-dot*) 88 | (((:vector double 2) (:vector double 2) double) double2-dot*) 89 | (((:vector double 3) (:vector double 3) double) double3-dot*) 90 | (((:vector double 4) (:vector double 4) double) double4-dot*))) 91 | (< (a a bool) (((int int bool) <) 92 | ((float float bool) <) 93 | ((doublet double bool) <))) 94 | (> (a a bool) (((int int bool) >) 95 | ((float float bool) >) 96 | ((double double bool) >))) 97 | (int2 (int int (:vector int 2)) 98 | (((int int (:vector int 2)) int2-values*))) 99 | (int3 (int int int (:vector int 3)) 100 | (((int int int (:vector int 3)) int3-values*))) 101 | (int4 (int int int int (:vector int 4)) 102 | (((int int int int (:vector int 4)) int4-values*))) 103 | (float2 (float float (:vector float 2)) 104 | (((float float (:vector float 2)) float2-values*))) 105 | (float3 (float float float (:vector float 3)) 106 | (((float float float (:vector float 3)) float3-values*))) 107 | (float4 (float float float float (:vector float 4)) 108 | (((float float float float (:vector float 4)) float4-values*))) 109 | (double2 (double double (:vector double 2)) 110 | (((double double (:vector double 2)) double2-values*))) 111 | (double3 (double double double (:vector double 3)) 112 | (((double double double (:vector double 3)) double3-values*))) 113 | (double4 (double double double double (:vector double 4)) 114 | (((double double double double (:vector double 4)) 115 | double4-values*))) 116 | (int2-x ((:vector int 2) int) 117 | ((((:vector int 2) int) int2-x*))) 118 | (int2-y ((:vector int 2) int) 119 | ((((:vector int 2) int) int2-y*))) 120 | (int3-x ((:vector int 3) int) 121 | ((((:vector int 3) int) int3-x*))) 122 | (int3-y ((:vector int 3) int) 123 | ((((:vector int 3) int) int3-y*))) 124 | (int3-z ((:vector int 3) int) 125 | ((((:vector int 3) int) int3-z*))) 126 | (int4-x ((:vector int 4) int) 127 | ((((:vector int 4) int) int4-x*))) 128 | (int4-y ((:vector int 4) int) 129 | ((((:vector int 4) int) int4-y*))) 130 | (int4-z ((:vector int 4) int) 131 | ((((:vector int 4) int) int4-z*))) 132 | (int4-w ((:vector int 4) int) 133 | ((((:vector int 4) int) int4-w*))) 134 | (float2-x ((:vector float 2) float) 135 | ((((:vector float 2) float) float2-x*))) 136 | (float2-y ((:vector float 2) float) 137 | ((((:vector float 2) float) float2-y*))) 138 | (float3-x ((:vector float 3) float) 139 | ((((:vector float 3) float) float3-x*))) 140 | (float3-y ((:vector float 3) float) 141 | ((((:vector float 3) float) float3-y*))) 142 | (float3-z ((:vector float 3) float) 143 | ((((:vector float 3) float) float3-z*))) 144 | (float4-x ((:vector float 4) float) 145 | ((((:vector float 4) float) float4-x*))) 146 | (float4-y ((:vector float 4) float) 147 | ((((:vector float 4) float) float4-y*))) 148 | (float4-z ((:vector float 4) float) 149 | ((((:vector float 4) float) float4-z*))) 150 | (float4-w ((:vector float 4) float) 151 | ((((:vector float 4) float) float4-w*))) 152 | (double2-x ((:vector double 2) double) 153 | ((((:vector double 2) double) double2-x*))) 154 | (double2-y ((:vector double 2) double) 155 | ((((:vector double 2) double) double2-y*))) 156 | (double3-x ((:vector double 3) double) 157 | ((((:vector double 3) double) double3-x*))) 158 | (double3-y ((:vector double 3) double) 159 | ((((:vector double 3) double) double3-y*))) 160 | (double3-z ((:vector double 3) double) 161 | ((((:vector double 3) double) double3-z*))) 162 | (double4-x ((:vector double 4) double) 163 | ((((:vector double 4) double) double4-x*))) 164 | (double4-y ((:vector double 4) double) 165 | ((((:vector double 4) double) double4-y*))) 166 | (double4-z ((:vector double 4) double) 167 | ((((:vector double 4) double) double4-z*))) 168 | (double4-w ((:vector double 4) double) 169 | ((((:vector double 4) double) double4-w*))) 170 | (aref ((:array a) int a) 171 | ((((:array int) int int) aref) 172 | (((:array (:vector int 2)) int (:vector int 2)) int2-aref*) 173 | (((:array (:vector int 3)) int (:vector int 3)) int3-aref*) 174 | (((:array (:vector int 4)) int (:vector int 4)) int4-aref*) 175 | (((:array float) int float) aref) 176 | (((:array (:vector float 2)) int (:vector float 2)) float2-aref*) 177 | (((:array (:vector float 3)) int (:vector float 3)) float3-aref*) 178 | (((:array (:vector float 4)) int (:vector float 4)) float4-aref*) 179 | (((:array double) int double) aref) 180 | (((:array (:vector double 2)) int (:vector double 2)) double2-aref*) 181 | (((:array (:vector double 3)) int (:vector double 3)) double3-aref*) 182 | (((:array (:vector double 4)) int (:vector double 4)) double4-aref*) 183 | )) 184 | (mod (int int int) (((int int int) mod))) 185 | (float (int float) (((int float) int->float))) 186 | (double (int double) (((int double) int->double))) 187 | ;; Mathematical functions. 188 | (rsqrt (a a) (((float float) rsqrt) 189 | ((double double) rsqrt))) 190 | (norm ((:vector a _) a) 191 | (;(((:vector int 2) int) int2-norm*) 192 | ;(((:vector int 3) int) int3-norm*) 193 | ;(((:vector int 4) int) int4-norm*) 194 | (((:vector float 2) float) float2-norm*) 195 | (((:vector float 3) float) float3-norm*) 196 | (((:vector float 4) float) float4-norm*) 197 | (((:vector double 2) double) double2-norm*) 198 | (((:vector double 3) double) double3-norm*) 199 | (((:vector double 4) double) double4-norm*))) 200 | )) 201 | 202 | (declaim (inline int->float)) 203 | (defun int->float (x) 204 | (float x 1.0)) 205 | 206 | (declaim (inline int->double)) 207 | (defun int->double (x) 208 | (float x 1.0d0)) 209 | 210 | (declaim (inline float->double)) 211 | (defun float->double (x) 212 | (float x 1.0d0)) 213 | 214 | (declaim (inline rsqrt)) 215 | (defun rsqrt (x) 216 | (declare (type (float 0.0) x)) 217 | (/ (sqrt x))) 218 | -------------------------------------------------------------------------------- /src/lang/compiler/lisp/compile-type.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.compiler.lisp.compile-type 8 | (:use :cl 9 | :avm) 10 | (:export :compile-type)) 11 | (in-package :avm.lang.compiler.lisp.compile-type) 12 | 13 | 14 | (defun compile-type (type) 15 | (cl-pattern:match type 16 | ('bool 'boolean) 17 | ('int 'fixnum) 18 | ('float 'single-float) 19 | ('double 'double-float) 20 | ((:vector base-type size) 21 | (let ((base-type1 (compile-type base-type))) 22 | `(values ,@(loop repeat size 23 | collect base-type1)))) 24 | ((:array type1) 25 | (cl-pattern:match type1 26 | ('int 'int-array) 27 | ('float 'float-array) 28 | ('double 'double-array) 29 | ((:vector 'int 2) 'int2-array) 30 | ((:vector 'int 3) 'int3-array) 31 | ((:vector 'int 4) 'int4-array) 32 | ((:vector 'float 2) 'float2-array) 33 | ((:vector 'float 3) 'float3-array) 34 | ((:vector 'float 4) 'float4-array) 35 | ((:vector 'double 2) 'double2-array) 36 | ((:vector 'double 3) 'double3-array) 37 | ((:vector 'double 4) 'double4-array) 38 | (_ (error "Must not be reached.")))) 39 | (_ (error "Must not be reached.")))) 40 | -------------------------------------------------------------------------------- /src/lang/compiler/lisp/compile.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.compiler.lisp.compile 8 | (:use :cl 9 | :avm 10 | :avm.lang.data 11 | :avm.lang.type 12 | :avm.lang.syntax 13 | :avm.lang.built-in 14 | :avm.lang.typenv 15 | :avm.lang.appenv 16 | :avm.lang.funenv 17 | :avm.lang.compiler.lisp.compile-type 18 | :avm.lang.compiler.lisp.varenv) 19 | (:export :compile-function 20 | :*genname-counter*)) 21 | (in-package :avm.lang.compiler.lisp.compile) 22 | 23 | 24 | ;; 25 | ;; Genname 26 | 27 | (defvar *genname-counter* 0) 28 | 29 | (defun genname (name) 30 | (prog1 (intern (format nil "~A~A" name *genname-counter*)) 31 | (incf *genname-counter*))) 32 | 33 | 34 | ;; 35 | ;; Compile 36 | 37 | (defun compile-function (name ftype args body venv aenv fenv &key entry-p rec-p) 38 | (assert (not (and entry-p (not rec-p)))) 39 | (let* ((name1 (compile-name name entry-p)) 40 | (pairs (loop for arg in args 41 | for type in (function-arg-types ftype) 42 | collect (cons arg type))) 43 | (venv1 (flet ((aux (venv pair) 44 | (destructuring-bind (arg . type) pair 45 | (extend-varenv arg type venv)))) 46 | (reduce #'aux pairs :initial-value venv))) 47 | (fenv1 (if rec-p 48 | (extend-funenv-function name name1 ftype args fenv) 49 | fenv))) 50 | (let ((args1 (compile-arguments args venv1)) 51 | (type-decls (compile-type-declarations ftype args venv1)) 52 | (body1 (compile-form body venv1 aenv fenv1))) 53 | (values name1 args1 `(,@type-decls ,body1))))) 54 | 55 | (defun compile-name (name entry-p) 56 | (if entry-p 57 | (let ((symbol-name (symbol-name name)) 58 | (symbol-package (symbol-package name))) 59 | (intern (format nil "%LISP-~A" symbol-name) symbol-package)) 60 | (genname name))) 61 | 62 | (defun compile-arguments (args venv) 63 | (loop for arg in args 64 | append (query-varenv arg venv))) 65 | 66 | (defun compile-type-declarations (ftype args venv) 67 | `((declare (optimize (speed 3) (safety 0))) 68 | (declare (ignorable ,@(loop for arg in args 69 | append (query-varenv arg venv)))) 70 | ,@(loop for arg in args 71 | for vars = (query-varenv arg venv) 72 | for type in (function-arg-types ftype) 73 | collect 74 | (cond 75 | ;; Scalar type and array type. 76 | ((or (scalar-type-p type) 77 | (array-type-p type)) 78 | (let ((type1 (compile-type type))) 79 | `(declare (type ,type1 ,@vars)))) 80 | ;; Vector type. 81 | ((vector-type-p type) 82 | (let ((type1 (compile-type (vector-type-base-type type)))) 83 | `(declare (type ,type1 ,@vars)))) 84 | (t (error "Must not be reached.")))))) 85 | 86 | (defun compile-form (form venv aenv fenv) 87 | (cond 88 | ((literal-p form) (compile-literal form venv aenv fenv)) 89 | ((reference-p form) (compile-reference form venv aenv fenv)) 90 | ((accessor-p form) (compile-accessor form venv aenv fenv)) 91 | ((the-p form) (compile-the form venv aenv fenv)) 92 | ((if-p form) (compile-if form venv aenv fenv)) 93 | ((let-p form) (compile-let form venv aenv fenv)) 94 | ((flet-p form) (compile-flet form venv aenv fenv)) 95 | ((labels-p form) (compile-labels form venv aenv fenv)) 96 | ((setf-p form) (compile-setf form venv aenv fenv)) 97 | ((apply-p form) (compile-apply form venv aenv fenv)) 98 | (t (error "The value ~S is an invalid form." form)))) 99 | 100 | (defun compile-literal (form venv aenv fenv) 101 | (declare (ignore venv aenv fenv)) 102 | form) 103 | 104 | (defun compile-reference (form venv aenv fenv) 105 | (declare (ignore aenv fenv)) 106 | (multiple-value-bind (vars type) (query-varenv form venv) 107 | (cond 108 | ((or (scalar-type-p type) 109 | (array-type-p type)) 110 | (car vars)) 111 | ((vector-type-p type) 112 | (let ((vector-values* (vector-type-values* type))) 113 | `(,vector-values* ,@vars))) 114 | (t (error "Must not be reached."))))) 115 | 116 | (defun vector-type-values* (type) 117 | (cl-pattern:match type 118 | ((:vector 'int 2) 'int2-values*) 119 | ((:vector 'int 3) 'int3-values*) 120 | ((:vector 'int 4) 'int4-values*) 121 | ((:vector 'float 2) 'float2-values*) 122 | ((:vector 'float 3) 'float3-values*) 123 | ((:vector 'float 4) 'float4-values*) 124 | ((:vector 'double 2) 'double2-values*) 125 | ((:vector 'double 3) 'double3-values*) 126 | ((:vector 'double 4) 'double4-values*) 127 | (_ (error "Must not be reached.")))) 128 | 129 | (defun compile-accessor (form venv aenv fenv) 130 | (compile-apply form venv aenv fenv)) 131 | 132 | (defun compile-the (form venv aenv fenv) 133 | (let ((value (the-value form))) 134 | (compile-form value venv aenv fenv))) 135 | 136 | (defun compile-if (form venv aenv fenv) 137 | (let ((test-form (if-test-form form)) 138 | (then-form (if-then-form form)) 139 | (else-form (if-else-form form))) 140 | (let ((test-form1 (compile-form test-form venv aenv fenv)) 141 | (then-form1 (compile-form then-form venv aenv fenv)) 142 | (else-form1 (compile-form else-form venv aenv fenv))) 143 | `(if ,test-form1 ,then-form1 ,else-form1)))) 144 | 145 | (defun compile-let (form venv aenv fenv) 146 | (let ((bindings (let-bindings form)) 147 | (body (let-body form))) 148 | (%compile-let bindings body venv aenv fenv venv))) 149 | 150 | (defun %compile-let (bindings body venv aenv fenv venv1) 151 | (if bindings 152 | (destructuring-bind ((var form) . bindings1) bindings 153 | (let* ((form1 (compile-form form venv aenv fenv)) 154 | (type (query-appenv (car bindings) aenv)) 155 | (venv2 (extend-varenv var type venv1)) 156 | (vars (query-varenv var venv2))) 157 | (cond 158 | ((or (scalar-type-p type) 159 | (array-type-p type)) 160 | (let ((type1 (compile-type type))) 161 | `(let ((,@vars ,form1)) 162 | (declare (ignorable ,@vars)) 163 | (declare (type ,type1 ,@vars)) 164 | ,(%compile-let bindings1 body venv aenv fenv venv2)))) 165 | ((vector-type-p type) 166 | (let ((type1 (compile-type (vector-type-base-type type)))) 167 | `(multiple-value-bind ,vars ,form1 168 | (declare (ignorable ,@vars)) 169 | (declare (type ,type1 ,@vars)) 170 | ,(%compile-let bindings1 body venv aenv fenv venv2)))) 171 | (t (error "Must not be reached."))))) 172 | (compile-form body venv1 aenv fenv))) 173 | 174 | (defun compile-flet (form venv aenv fenv) 175 | (let ((bindings (flet-bindings form)) 176 | (body (flet-body form))) 177 | (%compile-flet 'flet bindings body nil venv aenv fenv nil fenv))) 178 | 179 | (defun %compile-flet (op bindings body rec-p venv aenv fenv bindings1 fenv1) 180 | (if bindings 181 | (destructuring-bind ((name args form) . rest) bindings 182 | (let ((ftype (query-appenv (car bindings) aenv))) 183 | (multiple-value-bind (name1 args1 form1) 184 | (compile-function name ftype args form venv aenv fenv 185 | :entry-p nil :rec-p rec-p) 186 | (let ((bindings2 (cons `(,name1 ,args1 ,@form1) bindings1)) 187 | (fenv2 (extend-funenv-function name name1 ftype args fenv1))) 188 | (%compile-flet op rest body rec-p venv aenv fenv 189 | bindings2 fenv2))))) 190 | `(,op ,bindings1 191 | ,(compile-form body venv aenv fenv1)))) 192 | 193 | (defun compile-labels (form venv aenv fenv) 194 | (let ((bindings (labels-bindings form)) 195 | (body (labels-body form))) 196 | (%compile-flet 'labels bindings body t venv aenv fenv nil fenv))) 197 | 198 | (defun compile-setf (form venv aenv fenv) 199 | (let ((place (setf-place form)) 200 | (value (setf-value form))) 201 | (let ((place1 (compile-place place venv aenv fenv)) 202 | (value1 (compile-form value venv aenv fenv))) 203 | `(setf ,place1 ,value1)))) 204 | 205 | (defun compile-place (place venv aenv fenv) 206 | ;; Strip type specifier from compiled form to be well optimized. 207 | (if (reference-place-p place) 208 | (compile-form place venv aenv fenv) 209 | (third 210 | (compile-form place venv aenv fenv)))) 211 | 212 | (defun compile-apply (form venv aenv fenv) 213 | (let ((operator (apply-operator form))) 214 | (if (built-in-exists-p operator) 215 | (compile-built-in-apply form venv aenv fenv) 216 | (compile-user-apply form venv aenv fenv)))) 217 | 218 | (defun compile-built-in-apply (form venv aenv fenv) 219 | (let ((operator (apply-operator form)) 220 | (operands (apply-operands form))) 221 | (let ((argc (built-in-argc operator))) 222 | (unless (= argc (length operands)) 223 | (error "Invalid number of arguments: ~S" (length operands)))) 224 | (let* ((type (query-appenv form aenv)) 225 | (return-type (function-return-type type))) 226 | (let ((operator1 (built-in-operator :lisp operator type)) 227 | (operands1 (loop for operand in operands 228 | collect (compile-form operand venv aenv fenv))) 229 | (return-type1 (compile-type return-type))) 230 | `(the ,return-type1 (,operator1 ,@operands1)))))) 231 | 232 | (defun compile-user-apply (form venv aenv fenv) 233 | (let ((operator (apply-operator form)) 234 | (operands (apply-operands form))) 235 | (let ((argc (funenv-function-argc operator fenv))) 236 | (unless (= argc (length operands)) 237 | (error "Invalid number of arguments: ~S" (length operands)))) 238 | (let ((args (funenv-function-arguments operator fenv)) 239 | (arg-types (funenv-function-arg-types operator fenv))) 240 | (%compile-user-apply operator operands args arg-types 241 | venv aenv fenv nil)))) 242 | 243 | (defun %compile-user-apply (operator operands args arg-types venv aenv fenv 244 | vars1) 245 | (if operands 246 | (destructuring-bind (operand . operands1) operands 247 | (destructuring-bind (arg . args1) args 248 | (destructuring-bind (type . arg-types1) arg-types 249 | (let* ((operand1 (compile-form operand venv aenv fenv)) 250 | (venv1 (extend-varenv arg type venv)) 251 | (vars (query-varenv arg venv1)) 252 | (vars2 (append vars vars1))) 253 | (cond 254 | ((or (scalar-type-p type) 255 | (array-type-p type)) 256 | (let ((type1 (compile-type type))) 257 | `(let ((,@vars ,operand1)) 258 | (declare (type ,type1 ,@vars)) 259 | ,(%compile-user-apply operator operands1 args1 arg-types1 260 | venv1 aenv fenv vars2)))) 261 | ((vector-type-p type) 262 | (let ((type1 (compile-type (vector-type-base-type type)))) 263 | `(multiple-value-bind ,vars ,operand1 264 | (declare (type ,type1 ,@vars)) 265 | ,(%compile-user-apply operator operands1 args1 arg-types1 266 | venv1 aenv fenv vars2)))) 267 | (t (error "Must not be reached."))))))) 268 | (let* ((operator1 (funenv-function-name1 operator fenv)) 269 | (return-type (funenv-function-return-type operator fenv)) 270 | (return-type1 (compile-type return-type))) 271 | `(the ,return-type1 (,operator1 ,@(nreverse vars1)))))) 272 | -------------------------------------------------------------------------------- /src/lang/compiler/lisp/lang.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.compiler.lisp.lang 8 | (:use :cl 9 | :avm 10 | :avm.lang 11 | :avm.lang.type 12 | :avm.lang.kernel 13 | :avm.lang.expand-macro 14 | :avm.lang.convert-implicit-progn 15 | :avm.lang.binarize 16 | :avm.lang.convert-functions 17 | :avm.lang.free-variable 18 | :avm.lang.typenv 19 | :avm.lang.unienv 20 | :avm.lang.appenv 21 | :avm.lang.funenv 22 | :avm.lang.infer 23 | :avm.lang.compiler.lisp.varenv 24 | :avm.lang.compiler.lisp.compile 25 | ) 26 | (:shadowing-import-from :avm.lang.expand-macro 27 | :expand-macro)) 28 | (in-package :avm.lang.compiler.lisp.lang) 29 | 30 | 31 | (defun kernel->vars (kernel) 32 | (declare (ignore kernel)) 33 | ; (%extend-constants-vars kernel 34 | ; (%extend-globals-vars kernel 35 | nil);)) 36 | 37 | ;; (defun %extend-constants-typenv (kernel typenv) 38 | ;; (flet ((aux (typenv1 name) 39 | ;; (let ((type (kernel-constant-type kernel name))) 40 | ;; (extend-typenv name type typenv1)))) 41 | ;; (reduce #'aux (kernel-constant-names kernel) :initial-value typenv))) 42 | 43 | ;; (defun %extend-globals-typenv (kernel typenv) 44 | ;; (flet ((aux (typenv1 name) 45 | ;; (let ((type (kernel-global-type kernel name))) 46 | ;; (extend-typenv name type typenv1)))) 47 | ;; (reduce #'aux (kernel-global-names kernel) :initial-value typenv))) 48 | 49 | (defun kernel->typenv (kernel) 50 | (declare (ignore kernel)) 51 | ; (%extend-constants-typenv kernel 52 | ; (%extend-globals-typenv kernel 53 | (empty-typenv));)) 54 | 55 | (defun %extend-macros (kernel funenv) 56 | (flet ((aux (funenv1 name) 57 | (let ((args (kernel-macro-arguments kernel name)) 58 | (body (kernel-macro-body kernel name)) 59 | (expander (kernel-macro-expander kernel name))) 60 | (extend-funenv-macro name args body expander funenv1)))) 61 | (reduce #'aux (kernel-macro-names kernel) 62 | :initial-value funenv))) 63 | 64 | (defun %extend-functions (kernel funenv) 65 | (flet ((aux (funenv1 name) 66 | (let ((name1 (kernel-function-lisp-name kernel name)) 67 | (type (kernel-function-type kernel name)) 68 | (args (kernel-function-arguments kernel name))) 69 | (extend-funenv-function name name1 type args funenv1)))) 70 | (reduce #'aux (kernel-function-names kernel) 71 | :initial-value funenv))) 72 | 73 | (defun kernel->funenv (kernel) 74 | (%extend-macros kernel 75 | (%extend-functions kernel 76 | (empty-funenv)))) 77 | 78 | (defun subst-ftype (uenv ftype) 79 | (loop for type in ftype 80 | collect (query-unienv type uenv))) 81 | 82 | (defmethod compile-kernel-function ((engine (eql :lisp)) name args body kernel) 83 | (let* ((fenv (kernel->funenv kernel)) 84 | (body1 (convert-functions 85 | (binarize 86 | (convert-implicit-progn 87 | (expand-macro body fenv)))))) 88 | ;; Check free variable existence. 89 | (let ((vars (kernel->vars kernel))) 90 | (check-free-variable args body1 vars)) 91 | ;; Type inference. 92 | (let ((tenv (kernel->typenv kernel)) 93 | (aenv (empty-appenv)) 94 | (uenv (empty-unienv))) 95 | (multiple-value-bind (ftype aenv1 uenv1) 96 | (infer-function name args body1 tenv aenv uenv fenv) 97 | ;; Compilation. 98 | (let ((aenv2 (subst-appenv uenv1 aenv1)) 99 | (ftype1 (subst-ftype uenv1 ftype)) 100 | (venv (empty-varenv))) 101 | (multiple-value-bind (name1 args1 body2) 102 | (compile-function name ftype1 args body1 venv aenv2 fenv 103 | :entry-p t :rec-p t) 104 | (values name1 ftype1 105 | `(progn 106 | (declaim (inline ,name1)) 107 | (defun ,name1 ,args1 ,@body2))))))))) 108 | 109 | (defmethod compile-kernel-global (kernel name (engine (eql :lisp))) 110 | nil) 111 | 112 | (defmethod compile-kernel-constant (kernel name (engine (eql :lisp))) 113 | nil) 114 | -------------------------------------------------------------------------------- /src/lang/compiler/lisp/varenv.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.compiler.lisp.varenv 8 | (:use :cl 9 | :avm.lang.symbol 10 | :avm.lang.type) 11 | (:export :empty-varenv 12 | :extend-varenv 13 | :varenv-exists-p 14 | :query-varenv 15 | :*genvar-counter* 16 | )) 17 | (in-package :avm.lang.compiler.lisp.varenv) 18 | 19 | 20 | ;; 21 | ;; Variable environment 22 | 23 | (defun empty-varenv () 24 | nil) 25 | 26 | (defun extend-varenv (var type venv) 27 | (check-type var avm-symbol) 28 | (check-type type avm-type) 29 | (let ((vars (unique-var var type))) 30 | (cons (list var vars type) venv))) 31 | 32 | (defun varenv-exists-p (var venv) 33 | (check-type var avm-symbol) 34 | (and (cdr (assoc var venv)) 35 | t)) 36 | 37 | (defun query-varenv (var venv) 38 | (let ((entry (assoc var venv))) 39 | (if entry 40 | (values-list (cdr entry)) 41 | (error "The variable ~S not found." var)))) 42 | 43 | (defvar *genvar-counter* 0) 44 | 45 | (defun genvar (var) 46 | (prog1 (intern (format nil "~A~A" var *genvar-counter*)) 47 | (incf *genvar-counter*))) 48 | 49 | (defun unique-var (var type) 50 | (cond 51 | ((scalar-type-p type) (list (genvar var))) 52 | ((vector-type-p type) (loop repeat (vector-type-size type) 53 | collect (genvar var))) 54 | ((array-type-p type) (list (genvar var))) 55 | (t (error "Must not be reached.")))) 56 | -------------------------------------------------------------------------------- /src/lang/convert-functions.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.convert-functions 8 | (:use :cl 9 | :avm 10 | :avm.lang.syntax 11 | :avm.lang.built-in) 12 | (:export :convert-functions)) 13 | (in-package :avm.lang.convert-functions) 14 | 15 | 16 | ;; 17 | ;; Convert functions 18 | 19 | (defun convert-functions (form) 20 | (cond 21 | ((literal-p form) form) 22 | ((reference-p form) form) 23 | ((accessor-p form) (convert-accessor form)) 24 | ((the-p form) (convert-the form)) 25 | ((if-p form) (convert-if form)) 26 | ((let-p form) (convert-let form)) 27 | ((flet-p form) (convert-flet form)) 28 | ((labels-p form) (convert-labels form)) 29 | ((setf-p form) (convert-setf form)) 30 | ((apply-p form) (convert-apply form)) 31 | (t (error "The value ~S is an invalid form." form)))) 32 | 33 | (defun convert-accessor (form) 34 | (convert-apply form)) 35 | 36 | (defun convert-the (form) 37 | (let ((type (the-type form)) 38 | (value (the-value form))) 39 | (let ((value1 (convert-functions value))) 40 | `(the ,type ,value1)))) 41 | 42 | (defun convert-if (form) 43 | (let ((test-form (if-test-form form)) 44 | (then-form (if-then-form form)) 45 | (else-form (if-else-form form))) 46 | (let ((test-form1 (convert-functions test-form)) 47 | (then-form1 (convert-functions then-form)) 48 | (else-form1 (convert-functions else-form))) 49 | `(if ,test-form1 ,then-form1 ,else-form1)))) 50 | 51 | (defun convert-let (form) 52 | (flet ((aux (binding) 53 | (destructuring-bind (var value) binding 54 | (let ((value1 (convert-functions value))) 55 | `(,var ,value1))))) 56 | (let ((bindings (let-bindings form)) 57 | (body (let-body form))) 58 | (let ((bindings1 (mapcar #'aux bindings)) 59 | (body1 (convert-functions body))) 60 | `(let ,bindings1 ,body1))))) 61 | 62 | (defun convert-flet (form) 63 | (let ((bindings (flet-bindings form)) 64 | (body (flet-body form))) 65 | (%convert-flet 'flet bindings body))) 66 | 67 | (defun %convert-flet (op bindings body) 68 | (flet ((aux (binding) 69 | (destructuring-bind (name args body) binding 70 | (let ((args1 (append '(i n) args)) 71 | (body1 (convert-functions body))) 72 | `(,name ,args1 ,body1))))) 73 | (let ((bindings1 (mapcar #'aux bindings)) 74 | (body1 (convert-functions body))) 75 | `(,op ,bindings1 ,body1)))) 76 | 77 | (defun convert-labels (form) 78 | (let ((bindings (labels-bindings form)) 79 | (body (labels-body form))) 80 | (%convert-flet 'labels bindings body))) 81 | 82 | (defun convert-setf (form) 83 | (let ((place (setf-place form)) 84 | (value (setf-value form))) 85 | (let ((place1 (convert-functions place)) 86 | (value1 (convert-functions value))) 87 | `(setf ,place1 ,value1)))) 88 | 89 | (defun convert-apply (form) 90 | (let ((operator (apply-operator form)) 91 | (operands (apply-operands form))) 92 | (let ((operands1 (loop for operand in operands 93 | collect (convert-functions operand)))) 94 | (if (built-in-exists-p operator) 95 | `(,operator ,@operands1) 96 | `(,operator i n ,@operands1))))) 97 | -------------------------------------------------------------------------------- /src/lang/convert-implicit-progn.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.convert-implicit-progn 8 | (:use :cl 9 | :avm.lang.syntax) 10 | (:import-from :alexandria 11 | :with-gensyms) 12 | (:export :convert-implicit-progn)) 13 | (in-package :avm.lang.convert-implicit-progn) 14 | 15 | 16 | (defun convert-implicit-progn (forms) 17 | (destructuring-bind (form1 . forms1) forms 18 | (if forms1 19 | (with-gensyms (var) 20 | `(let ((,var ,(convert-form form1))) 21 | ,(convert-implicit-progn forms1))) 22 | (convert-form form1)))) 23 | 24 | (defun convert-form (form) 25 | (cond 26 | ((literal-p form) form) 27 | ((reference-p form) form) 28 | ((accessor-p form) (convert-accessor form)) 29 | ((the-p form) (convert-the form)) 30 | ((if-p form) (convert-if form)) 31 | ((let-p form) (convert-let form)) 32 | ((flet-p form) (convert-flet form)) 33 | ((labels-p form) (convert-labels form)) 34 | ((setf-p form) (convert-setf form)) 35 | ((apply-p form) (convert-apply form)) 36 | (t (error "The value ~S is an invalid form." form)))) 37 | 38 | (defun convert-accessor (form) 39 | (convert-apply form)) 40 | 41 | (defun convert-the (form) 42 | (let ((type (the-type form)) 43 | (value (the-value form))) 44 | (let ((value1 (convert-form value))) 45 | `(the ,type ,value1)))) 46 | 47 | (defun convert-if (form) 48 | (let ((test-form (if-test-form form)) 49 | (then-form (if-then-form form)) 50 | (else-form (if-else-form form))) 51 | (let ((test-form1 (convert-form test-form)) 52 | (then-form1 (convert-form then-form)) 53 | (else-form1 (convert-form else-form))) 54 | `(if ,test-form1 ,then-form1 ,else-form1)))) 55 | 56 | (defun convert-let (form) 57 | (let ((bindings (let-bindings% form)) 58 | (body (let-body% form))) 59 | (let ((bindings1 (loop for (var value) in bindings 60 | for value1 = (convert-form value) 61 | collect `(,var ,value1))) 62 | (body1 (convert-implicit-progn body))) 63 | `(let ,bindings1 ,body1)))) 64 | 65 | (defun convert-flet (form) 66 | (let ((bindings (flet-bindings% form)) 67 | (body (flet-body% form))) 68 | (%convert-flet 'flet bindings body))) 69 | 70 | (defun %convert-flet (op bindings body) 71 | (let ((bindings1 (loop for (name args . body) in bindings 72 | for body1 = (convert-implicit-progn body) 73 | collect `(,name ,args ,body1))) 74 | (body1 (convert-implicit-progn body))) 75 | `(,op ,bindings1 ,body1))) 76 | 77 | (defun convert-labels (form) 78 | (let ((bindings (labels-bindings% form)) 79 | (body (labels-body% form))) 80 | (%convert-flet 'labels bindings body))) 81 | 82 | (defun convert-setf (form) 83 | (let ((place (setf-place form)) 84 | (value (setf-value form))) 85 | (let ((place1 (convert-place place)) 86 | (value1 (convert-form value))) 87 | `(setf ,place1 ,value1)))) 88 | 89 | (defun convert-place (place) 90 | (cond 91 | ((reference-place-p place) place) 92 | ((vector-place-p place) (convert-vector-place place)) 93 | ((array-place-p place) (convert-array-place place)) 94 | (t (error "Must not be reached.")))) 95 | 96 | (defun convert-vector-place (place) 97 | (let ((operator (vector-place-operator place)) 98 | (value (vector-place-value place))) 99 | (let ((value1 (convert-place value))) 100 | `(,operator ,value1)))) 101 | 102 | (defun convert-array-place (place) 103 | (let ((value (array-place-value place)) 104 | (index (array-place-index place))) 105 | (let ((value1 (convert-place value)) 106 | (index1 (convert-form index))) 107 | `(aref ,value1 ,index1)))) 108 | 109 | (defun convert-apply (form) 110 | (let ((operator (apply-operator form)) 111 | (operands (apply-operands form))) 112 | (let ((operands1 (loop for operand in operands 113 | collect (convert-form operand)))) 114 | `(,operator ,@operands1)))) 115 | -------------------------------------------------------------------------------- /src/lang/data.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.data 8 | (:use :cl 9 | :cl-tuples 10 | :avm) 11 | (:export)) ; Symbols are exported via EXPORTs. 12 | (in-package :avm.lang.data) 13 | 14 | 15 | ;; 16 | ;; Helpers 17 | 18 | (eval-when (:compile-toplevel) 19 | 20 | (defun type-base-type (type) 21 | (ecase type 22 | ((int int2 int3 int4) 'fixnum) 23 | ((float float2 float3 float4) 'single-float) 24 | ((double double2 double3 double4) 'double-float))) 25 | 26 | (defun type-size (type) 27 | (ecase type 28 | ((int2 float2 double2) 2) 29 | ((int3 float3 double3) 3) 30 | ((int4 float4 double4) 4))) 31 | 32 | (defun type-initial-element (type) 33 | (ecase (type-base-type type) 34 | (fixnum 0) 35 | (single-float 0.0f0) 36 | (double-float 0.0d0))) 37 | 38 | (defun type-elements (type) 39 | (subseq '(x y z w) 0 (type-size type))) 40 | 41 | (defun type-avm (type avm) 42 | (intern (format nil "~A-~A" type avm) #.*package*)) 43 | 44 | (defun type-values* (type) 45 | (type-avm type "VALUES*")) 46 | 47 | (defun type-x* (type x) 48 | (type-avm type (format nil "~A*" x))) 49 | 50 | (defun type-aref* (type) 51 | (type-avm type "AREF*")) 52 | 53 | (defun type-make-array (type) 54 | (intern (format nil "MAKE-~A-ARRAY" type) #.*package*)) 55 | 56 | (defun type-array (type) 57 | (intern (format nil "~A-ARRAY" type) #.*package*)) 58 | 59 | (defun type-array-dimensions (type) 60 | (intern (format nil "~A-ARRAY-DIMENSIONS" type) #.*package*)) 61 | 62 | (defun type-add* (type) 63 | (type-avm type "ADD*")) 64 | 65 | (defun type-sub* (type) 66 | (type-avm type "SUB*")) 67 | 68 | (defun type-scale* (type) 69 | (type-avm type "SCALE*")) 70 | 71 | (defun type-%scale* (type) 72 | (type-avm type "%SCALE*")) 73 | 74 | (defun type-scale-recip* (type) 75 | (type-avm type "SCALE-RECIP*")) 76 | 77 | (defun type-norm* (type) 78 | (type-avm type "NORM*")) 79 | 80 | (defun type-dot* (type) 81 | (type-avm type "DOT*")) 82 | 83 | (defun type-args (type i) 84 | (loop for arg in (type-elements type) 85 | collect (intern (format nil "~A~A" arg i) #.*package*))) 86 | 87 | (defun type-xs (type x) 88 | (loop repeat (type-size type) 89 | for i from 1 90 | collect (intern (format nil "~A~A" x i) #.*package*))) 91 | ) 92 | 93 | 94 | ;; 95 | ;; Scalar types 96 | 97 | (eval-when (:compile-toplevel) 98 | (defun define-scalar-type-form (type) 99 | `(progn 100 | ;; Define and export FOO type. 101 | ;(deftype ,type () 102 | ; ',(type-base-type type)) 103 | ;(export ',type) 104 | ;; Define and export FOO-ARRAY type. 105 | (deftype ,(type-array type) () 106 | '(simple-array ,(type-base-type type) *)) 107 | (export ',(type-array type)) 108 | ;; Define and export MAKE-FOO-ARRAY. 109 | (defun ,(type-make-array type) (dimensions &key initial-element) 110 | (make-array dimensions 111 | :initial-element (or initial-element 112 | ,(type-initial-element type)) 113 | :element-type ',(type-base-type type))) 114 | (export ',(type-make-array type)) 115 | ;; Define and export FOO-AREF* 116 | (defmacro ,(type-aref* type) (array array-index) 117 | `(aref ,array ,array-index)) 118 | (export ',(type-aref* type)) 119 | ;; Define and export FOO-ARRAY-DIMENSIONS. 120 | (defun ,(type-array-dimensions type) (array) 121 | (array-dimension array 0)) 122 | (export ',(type-array-dimensions type)) 123 | (declaim (ftype (function (,(type-array type)) fixnum) 124 | ,(type-array-dimensions type))) 125 | ))) 126 | 127 | (defmacro define-scalar-type (type) 128 | (define-scalar-type-form type)) 129 | 130 | (define-scalar-type int) 131 | (define-scalar-type float) 132 | (define-scalar-type double) 133 | 134 | 135 | ;; 136 | ;; Vector types 137 | 138 | (eval-when (:compile-toplevel) 139 | (defun define-tuple-type-form (type) 140 | `(progn 141 | ;; Define FOO tuple type. 142 | (def-tuple-type ,type 143 | :tuple-element-type ,(type-base-type type) 144 | :initial-element ,(type-initial-element type) 145 | :elements ,(type-elements type)) 146 | ;; Export FOO type. 147 | ; (export ',type) 148 | ;; Export FOO-VALUES*. 149 | (export ',(type-values* type)) 150 | ;; Define and export FOO-{x,y,z,w}* 151 | ,@(loop for x in (type-elements type) 152 | append 153 | `((def-tuple-op ,(type-x* type x) 154 | ((a ,type ,(type-elements type))) 155 | (:return ,(type-base-type type) 156 | ,x)) 157 | (export ',(type-x* type x)))) 158 | ;; Define and export FOO-ARRAY type. 159 | (deftype ,(type-array type) () 160 | '(simple-array ,(type-base-type type) *)) 161 | (export ',(type-array type)) 162 | ;; Export MAKE-FOO-ARRAY. 163 | (export ',(type-make-array type)) 164 | ;; Export FOO-AREF*. 165 | (export ',(type-aref* type)) 166 | ;; Export FOO-ARRAY-DIMENSIONS 167 | (export ',(type-array-dimensions type)) 168 | (declaim (ftype (function (,(type-array type)) fixnum) 169 | ,(type-array-dimensions type))) 170 | ))) 171 | 172 | (eval-when (:compile-toplevel) 173 | (defun define-tuple-arithmetic-form (type) 174 | `(progn 175 | ;; Define and export FOO-ADD* operator. 176 | (def-tuple-op ,(type-add* type) 177 | ((a ,type ,(type-args type 1)) 178 | (b ,type ,(type-args type 2))) 179 | (:return ,type 180 | (,(type-values* type) ,@(loop for x in (type-args type 1) 181 | for y in (type-args type 2) 182 | collect `(+ ,x ,y))))) 183 | (export ',(type-add* type)) 184 | ;; Define and export FOO-SUB* operator. 185 | (def-tuple-op ,(type-sub* type) 186 | ((a ,type ,(type-args type 1)) 187 | (b ,type ,(type-args type 2))) 188 | (:return ,type 189 | (,(type-values* type) ,@(loop for x in (type-args type 1) 190 | for y in (type-args type 2) 191 | collect `(- ,x ,y))))) 192 | (export ',(type-sub* type)) 193 | ;; Define and export FOO-SCALE* operator. 194 | (def-tuple-op ,(type-scale* type) 195 | ((a ,type ,(type-elements type)) 196 | (val ,(type-base-type type))) 197 | (:return ,type 198 | (let ((k val)) 199 | (,(type-values* type) ,@(loop for x in (type-elements type) 200 | collect `(* ,x k)))))) 201 | (export ',(type-scale* type)) 202 | ;; Define and export FOO-%SCALE* operator. 203 | (defmacro ,(type-%scale* type) (k x) 204 | (list ',(type-scale* type) x k)) 205 | (export ',(type-%scale* type)) 206 | ;; Define and export FOO-SCALE-RECIP* operator. 207 | (def-tuple-op ,(type-scale-recip* type) 208 | ((a ,type ,(type-elements type)) 209 | (val ,(type-base-type type))) 210 | (:return ,type 211 | (let ((k val)) 212 | (,(type-values* type) ,@(loop for x in (type-elements type) 213 | collect `(/ ,x k)))))) 214 | (export ',(type-scale-recip* type)) 215 | ))) 216 | 217 | (eval-when (:compile-toplevel) 218 | (defun define-tuple-math-form (type) 219 | `(progn 220 | ;; Define and export FOO-NORM* function. 221 | (def-tuple-op ,(type-norm* type) 222 | ((a ,type ,(type-elements type))) 223 | (:return ,(type-base-type type) 224 | (sqrt (+ ,@(loop for x in (type-elements type) 225 | collect `(* ,x ,x)))))) 226 | (export ',(type-norm* type)) 227 | ;; Define and export FOO-DOT* function. 228 | (def-tuple-op ,(type-dot* type) 229 | ((a ,type ,(type-args type 1)) 230 | (b ,type ,(type-args type 2))) 231 | (:return ,(type-base-type type) 232 | (+ ,@(loop for x in (type-args type 1) 233 | for y in (type-args type 2) 234 | collect `(* ,x ,y))))) 235 | (export ',(type-dot* type)) 236 | ))) 237 | 238 | (eval-when (:compile-toplevel) 239 | (defun define-vector-type-form (type) 240 | `(progn 241 | ,@(cdr (define-tuple-type-form type)) 242 | ,@(cdr (define-tuple-arithmetic-form type)) 243 | ,@(cdr (define-tuple-math-form type)) 244 | ))) 245 | 246 | (defmacro define-vector-type (type) 247 | (define-vector-type-form type)) 248 | 249 | (define-vector-type int2) 250 | (define-vector-type int3) 251 | (define-vector-type int4) 252 | (define-vector-type float2) 253 | (define-vector-type float3) 254 | (define-vector-type float4) 255 | (define-vector-type double2) 256 | (define-vector-type double3) 257 | (define-vector-type double4) 258 | -------------------------------------------------------------------------------- /src/lang/expand-macro.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.expand-macro 8 | (:use :cl 9 | :avm.lang.symbol 10 | :avm.lang.syntax 11 | :avm.lang.funenv) 12 | (:export :expand-macro)) 13 | (in-package :avm.lang.expand-macro) 14 | 15 | 16 | (defun macro-p (form fenv) 17 | (cl-pattern:match form 18 | ((name . _) (and (avm-symbol-p name) 19 | (funenv-macro-exists-p name fenv))) 20 | (_ nil))) 21 | 22 | (defun expand-macro (forms fenv) 23 | (loop for form in forms 24 | collect (expand-macro-form form fenv))) 25 | 26 | (defun expand-macro-form (form fenv) 27 | (cond 28 | ((macro-p form fenv) (expand-macro-macro form fenv)) 29 | ((literal-p form) (expand-macro-literal form fenv)) 30 | ((reference-p form) (expand-macro-reference form fenv)) 31 | ((accessor-p form) (expand-macro-accessor form fenv)) 32 | ((the-p form) (expand-macro-the form fenv)) 33 | ((if-p form) (expand-macro-if form fenv)) 34 | ((let-p form) (expand-macro-let form fenv)) 35 | ((flet-p form) (expand-macro-flet form fenv)) 36 | ((labels-p form) (expand-macro-labels form fenv)) 37 | ((setf-p form) (expand-macro-setf form fenv)) 38 | ((apply-p form) (expand-macro-apply form fenv)) 39 | (t (error "The value ~S is an invalid form." form)))) 40 | 41 | (defun expand-macro-macro (form fenv) 42 | (destructuring-bind (name . args) form 43 | (let ((expander (funenv-macro-expander name fenv))) 44 | (expand-macro-form (funcall expander args) fenv)))) 45 | 46 | (defun expand-macro-literal (form fenv) 47 | (declare (ignore fenv)) 48 | form) 49 | 50 | (defun expand-macro-reference (form fenv) 51 | (declare (ignore fenv)) 52 | form) 53 | 54 | (defun expand-macro-accessor (form fenv) 55 | (expand-macro-apply form fenv)) 56 | 57 | (defun expand-macro-the (form fenv) 58 | (let ((type (the-type form)) 59 | (value (the-value form))) 60 | (let ((value1 (expand-macro-form value fenv))) 61 | `(the ,type ,value1)))) 62 | 63 | (defun expand-macro-if (form fenv) 64 | (let ((test-form (if-test-form form)) 65 | (then-form (if-then-form form)) 66 | (else-form (if-else-form form))) 67 | (let ((test-form1 (expand-macro-form test-form fenv)) 68 | (then-form1 (expand-macro-form then-form fenv)) 69 | (else-form1 (expand-macro-form else-form fenv))) 70 | `(if ,test-form1 ,then-form1 ,else-form1)))) 71 | 72 | (defun expand-macro-let (form fenv) 73 | (let ((bindings (let-bindings% form)) 74 | (body (let-body% form))) 75 | (let ((bindings1 (loop for (var value) in bindings 76 | for value1 = (expand-macro-form value fenv) 77 | collect `(,var ,value1))) 78 | (body1 (expand-macro body fenv))) 79 | `(let ,bindings1 ,@body1)))) 80 | 81 | (defun expand-macro-flet (form fenv) 82 | (let ((bindings (flet-bindings% form)) 83 | (body (flet-body% form))) 84 | (%expand-macro-flet 'flet bindings body fenv))) 85 | 86 | (defun %expand-macro-flet (op bindings body fenv) 87 | (let ((bindings1 (loop for (name args . body) in bindings 88 | for body1 = (expand-macro body fenv) 89 | collect `(,name ,args ,@body1))) 90 | (body1 (expand-macro body fenv))) 91 | `(,op ,bindings1 ,@body1))) 92 | 93 | (defun expand-macro-labels (form fenv) 94 | (let ((bindings (labels-bindings% form)) 95 | (body (labels-body% form))) 96 | (%expand-macro-flet 'labels bindings body fenv))) 97 | 98 | (defun expand-macro-setf (form fenv) 99 | (let ((place (setf-place form)) 100 | (value (setf-value form))) 101 | (let ((place1 (expand-macro-place place fenv)) 102 | (value1 (expand-macro-form value fenv))) 103 | `(setf ,place1 ,value1)))) 104 | 105 | (defun expand-macro-place (place fenv) 106 | (cond 107 | ((reference-place-p place) (expand-macro-reference place fenv)) 108 | ((vector-place-p place) (expand-macro-vector-place place fenv)) 109 | ((array-place-p place) (expand-macro-array-place place fenv)) 110 | (t (error "Must not be reached.")))) 111 | 112 | (defun expand-macro-vector-place (place fenv) 113 | (let ((operator (vector-place-operator place)) 114 | (value (vector-place-value place))) 115 | (let ((value1 (expand-macro-place value fenv))) 116 | `(,operator ,value1)))) 117 | 118 | (defun expand-macro-array-place (place fenv) 119 | (let ((value (array-place-value place)) 120 | (index (array-place-index place))) 121 | (let ((value1 (expand-macro-place value fenv)) 122 | (index1 (expand-macro-form index fenv))) 123 | `(aref ,value1 ,index1)))) 124 | 125 | (defun expand-macro-apply (form fenv) 126 | (let ((operator (apply-operator form)) 127 | (operands (apply-operands form))) 128 | (let ((operands1 (loop for operand in operands 129 | collect (expand-macro-form operand fenv)))) 130 | `(,operator ,@operands1)))) 131 | -------------------------------------------------------------------------------- /src/lang/free-variable.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.free-variable 8 | (:use :cl 9 | :avm 10 | :avm.lang.syntax) 11 | (:export :check-free-variable)) 12 | (in-package :avm.lang.free-variable) 13 | 14 | 15 | ;; 16 | ;; Check free variable existence 17 | 18 | (defun check-free-variable (args form vars) 19 | (let ((vars1 (append args vars))) 20 | (%check-free-variable form vars vars1)) 21 | form) 22 | 23 | (defun %check-free-variable (form vars0 vars) 24 | (cond 25 | ((literal-p form) nil) 26 | ((reference-p form) (check-free-variable-reference form vars0 vars)) 27 | ((accessor-p form) (check-free-variable-accessor form vars0 vars)) 28 | ((the-p form) (check-free-variable-the form vars0 vars)) 29 | ((if-p form) (check-free-variable-if form vars0 vars)) 30 | ((let-p form) (check-free-variable-let form vars0 vars)) 31 | ((flet-p form) (check-free-variable-flet form vars0 vars)) 32 | ((labels-p form) (check-free-variable-labels form vars0 vars)) 33 | ((setf-p form) (check-free-variable-setf form vars0 vars)) 34 | ((apply-p form) (check-free-variable-apply form vars0 vars)) 35 | (t (error "The value ~S is an invalid form." form)))) 36 | 37 | (defun check-free-variable-reference (form vars0 vars) 38 | (declare (ignore vars0)) 39 | (or (member form vars) 40 | (error "The variable ~S not found." form))) 41 | 42 | (defun check-free-variable-accessor (form vars0 vars) 43 | (check-free-variable-apply form vars0 vars)) 44 | 45 | (defun check-free-variable-the (form vars0 vars) 46 | (let ((value (the-value form))) 47 | (%check-free-variable value vars0 vars))) 48 | 49 | (defun check-free-variable-if (form vars0 vars) 50 | (let ((test-form (if-test-form form)) 51 | (then-form (if-then-form form)) 52 | (else-form (if-else-form form))) 53 | (%check-free-variable test-form vars0 vars) 54 | (%check-free-variable then-form vars0 vars) 55 | (%check-free-variable else-form vars0 vars))) 56 | 57 | (defun check-free-variable-let (form vars0 vars) 58 | (flet ((aux (vars1 binding) 59 | (destructuring-bind (var value) binding 60 | (%check-free-variable value vars0 vars) 61 | (cons var vars1)))) 62 | (let ((bindings (let-bindings form)) 63 | (body (let-body form))) 64 | (let ((vars1 (reduce #'aux bindings :initial-value vars))) 65 | (%check-free-variable body vars0 vars1))))) 66 | 67 | (defun check-free-variable-flet (form vars0 vars) 68 | (let ((bindings (flet-bindings form)) 69 | (body (flet-body form))) 70 | (%check-free-variable-flet bindings body vars0 vars))) 71 | 72 | (defun %check-free-variable-flet (bindings body vars0 vars) 73 | (flet ((aux (binding) 74 | (destructuring-bind (name args body) binding 75 | (declare (ignore name)) 76 | (check-free-variable args body vars0)))) 77 | (loop for binding in bindings 78 | do (aux binding)) 79 | (%check-free-variable body vars0 vars))) 80 | 81 | (defun check-free-variable-labels (form vars0 vars) 82 | (let ((bindings (labels-bindings form)) 83 | (body (labels-body form))) 84 | (%check-free-variable-flet bindings body vars0 vars))) 85 | 86 | (defun check-free-variable-setf (form vars0 vars) 87 | (let ((place (setf-place form)) 88 | (value (setf-value form))) 89 | (%check-free-variable place vars0 vars) 90 | (%check-free-variable value vars0 vars))) 91 | 92 | (defun check-free-variable-apply (form vars0 vars) 93 | (let ((operands (apply-operands form))) 94 | (loop for operand in operands 95 | do (%check-free-variable operand vars0 vars)))) 96 | -------------------------------------------------------------------------------- /src/lang/funenv.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.funenv 8 | (:use :cl 9 | :avm.lang.symbol 10 | :avm.lang.type) 11 | (:export :empty-funenv 12 | ;; Function 13 | :extend-funenv-function 14 | :funenv-function-exists-p 15 | :funenv-function-name 16 | :funenv-function-name1 17 | :funenv-function-type 18 | :funenv-function-arg-types 19 | :funenv-function-return-type 20 | :funenv-function-arguments 21 | :funenv-function-argc 22 | ;; Macro 23 | :extend-funenv-macro 24 | :funenv-macro-exists-p 25 | :funenv-macro-name 26 | :funenv-macro-arguments 27 | :funenv-macro-body 28 | :funenv-macro-expander)) 29 | (in-package :avm.lang.funenv) 30 | 31 | 32 | ;; 33 | ;; Function environment 34 | 35 | (defun empty-funenv () 36 | nil) 37 | 38 | 39 | ;; 40 | ;; Function environment - function 41 | 42 | (defun extend-funenv-function (name name1 type args fenv) 43 | (check-type name avm-symbol) 44 | (check-type name1 symbol) 45 | (check-type type function-type) 46 | (loop for arg in args 47 | do (check-type arg avm-symbol)) 48 | (assert (= (1- (length type)) (length args))) 49 | (cons (list name :function name1 type args) fenv)) 50 | 51 | (defun funenv-function-exists-p (name fenv) 52 | (check-type name avm-symbol) 53 | (let ((entry (assoc name fenv))) 54 | (and entry 55 | (eq (second entry) :function)))) 56 | 57 | (defun %lookup-function (name fenv) 58 | (if (funenv-function-exists-p name fenv) 59 | (assoc name fenv) 60 | (error "The function ~S is undefined." name))) 61 | 62 | (defun funenv-function-name (name fenv) 63 | (first (%lookup-function name fenv))) 64 | 65 | (defun funenv-function-name1 (name fenv) 66 | (third (%lookup-function name fenv))) 67 | 68 | (defun funenv-function-type (name fenv) 69 | (fourth (%lookup-function name fenv))) 70 | 71 | (defun funenv-function-arg-types (name fenv) 72 | (function-arg-types (funenv-function-type name fenv))) 73 | 74 | (defun funenv-function-return-type (name fenv) 75 | (function-return-type (funenv-function-type name fenv))) 76 | 77 | (defun funenv-function-arguments (name fenv) 78 | (fifth (%lookup-function name fenv))) 79 | 80 | (defun funenv-function-argc (name fenv) 81 | (length (funenv-function-arguments name fenv))) 82 | 83 | 84 | ;; 85 | ;; Function environment - macro 86 | 87 | (defun extend-funenv-macro (name args body expander fenv) 88 | (check-type name avm-symbol) 89 | (check-type body list) 90 | (check-type expander function) 91 | (cons (list name :macro args body expander) fenv)) 92 | 93 | (defun funenv-macro-exists-p (name fenv) 94 | (check-type name avm-symbol) 95 | (let ((entry (assoc name fenv))) 96 | (and entry 97 | (eq (second entry) :macro)))) 98 | 99 | (defun %lookup-macro (name fenv) 100 | (if (funenv-macro-exists-p name fenv) 101 | (assoc name fenv) 102 | (error "The macro ~S is undefined." name))) 103 | 104 | (defun funenv-macro-name (name fenv) 105 | (first (%lookup-macro name fenv))) 106 | 107 | (defun funenv-macro-arguments (name fenv) 108 | (third (%lookup-macro name fenv))) 109 | 110 | (defun funenv-macro-body (name fenv) 111 | (fourth (%lookup-macro name fenv))) 112 | 113 | (defun funenv-macro-expander (name fenv) 114 | (fifth (%lookup-macro name fenv))) 115 | -------------------------------------------------------------------------------- /src/lang/infer.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.infer 8 | (:use :cl 9 | :avm 10 | :avm.lang.type 11 | :avm.lang.syntax 12 | :avm.lang.built-in 13 | :avm.lang.unienv 14 | :avm.lang.typenv 15 | :avm.lang.appenv 16 | :avm.lang.funenv) 17 | (:export :infer-function)) 18 | (in-package :avm.lang.infer) 19 | 20 | 21 | ;; 22 | ;; Type inference 23 | 24 | (defun infer-function (name args body tenv aenv uenv fenv &key rec-p) 25 | (let* ((arg-types (loop for arg in args 26 | collect (if (member arg '(i n)) 27 | 'int (gentype)))) 28 | (return-type (gentype)) 29 | (ftype (make-function-type arg-types return-type))) 30 | (let ((tenv1 (flet ((aux (tenv pair) 31 | (destructuring-bind (arg . type) pair 32 | (extend-typenv arg type tenv)))) 33 | (reduce #'aux (mapcar #'cons args arg-types) 34 | :initial-value tenv))) 35 | (fenv1 (if rec-p 36 | (extend-funenv-function name nil ftype args fenv) 37 | fenv))) 38 | (multiple-value-bind (return-type1 aenv1 uenv1) 39 | (infer-form body tenv1 aenv uenv fenv1) 40 | (multiple-value-bind (_ uenv2) (unify return-type return-type1 uenv1) 41 | (declare (ignore _)) 42 | (values ftype aenv1 uenv2)))))) 43 | 44 | (defun infer-form (form tenv aenv uenv fenv) 45 | (cond 46 | ((literal-p form) (infer-literal form tenv aenv uenv fenv)) 47 | ((reference-p form) (infer-reference form tenv aenv uenv fenv)) 48 | ((accessor-p form) (infer-accessor form tenv aenv uenv fenv)) 49 | ((the-p form) (infer-the form tenv aenv uenv fenv)) 50 | ((if-p form) (infer-if form tenv aenv uenv fenv)) 51 | ((let-p form) (infer-let form tenv aenv uenv fenv)) 52 | ((flet-p form) (infer-flet form tenv aenv uenv fenv)) 53 | ((labels-p form) (infer-labels form tenv aenv uenv fenv)) 54 | ((setf-p form) (infer-setf form tenv aenv uenv fenv)) 55 | ((apply-p form) (infer-apply form tenv aenv uenv fenv)) 56 | (t (error "The value ~S is an invalid form." form)))) 57 | 58 | (defun infer-literal (form tenv aenv uenv fenv) 59 | (declare (ignore tenv fenv)) 60 | (cond 61 | ((int-literal-p form) (values 'int aenv uenv)) 62 | ((float-literal-p form) (values 'float aenv uenv)) 63 | ((double-literal-p form) (values 'double aenv uenv)) 64 | (t (error "Must not be reached.")))) 65 | 66 | (defun infer-reference (form tenv aenv uenv fenv) 67 | (declare (ignore fenv)) 68 | (let ((type (query-typenv form tenv))) 69 | (if type 70 | (let ((type1 (query-unienv type uenv))) 71 | (values type1 aenv uenv)) 72 | (error "The variable ~S not found." form)))) 73 | 74 | (defun infer-accessor (form tenv aenv uenv fenv) 75 | (infer-apply form tenv aenv uenv fenv)) 76 | 77 | (defun infer-the (form tenv aenv uenv fenv) 78 | (let ((type (parse-type (the-type form))) 79 | (value (the-value form))) 80 | (multiple-value-bind (type1 aenv1 uenv1) 81 | (infer-form value tenv aenv uenv fenv) 82 | (multiple-value-bind (type2 uenv2) (unify type type1 uenv1) 83 | (values type2 aenv1 uenv2))))) 84 | 85 | (defun infer-if (form tenv aenv uenv fenv) 86 | (let ((test-form (if-test-form form)) 87 | (then-form (if-then-form form)) 88 | (else-form (if-else-form form))) 89 | (multiple-value-bind (test-type1 aenv1 uenv1) 90 | (infer-form test-form tenv aenv uenv fenv) 91 | (multiple-value-bind (_ uenv2) 92 | (unify test-type1 'bool uenv1) 93 | (declare (ignore _)) 94 | (multiple-value-bind (then-type1 aenv2 uenv3) 95 | (infer-form then-form tenv aenv1 uenv2 fenv) 96 | (multiple-value-bind (else-type1 aenv3 uenv4) 97 | (infer-form else-form tenv aenv2 uenv3 fenv) 98 | (multiple-value-bind (then-type2 uenv5) 99 | (unify then-type1 else-type1 uenv4) 100 | (values then-type2 aenv3 uenv5)))))))) 101 | 102 | (defun infer-let (form tenv aenv uenv fenv) 103 | (flet ((aux (tenv-aenv-uenv binding) 104 | (destructuring-bind (tenv1 aenv1 uenv1) tenv-aenv-uenv 105 | (destructuring-bind (var value) binding 106 | (multiple-value-bind (type aenv2 uenv2) 107 | (infer-form value tenv aenv1 uenv1 fenv) 108 | (let ((tenv2 (extend-typenv var type tenv1)) 109 | (aenv3 (extend-appenv binding type aenv2))) 110 | (list tenv2 aenv3 uenv2))))))) 111 | (let ((bindings (let-bindings form)) 112 | (body (let-body form))) 113 | (destructuring-bind (tenv1 aenv1 uenv1) 114 | (reduce #'aux bindings :initial-value (list tenv aenv uenv)) 115 | (infer-form body tenv1 aenv1 uenv1 fenv))))) 116 | 117 | (defun infer-flet (form tenv aenv uenv fenv) 118 | (let ((bindings (flet-bindings form)) 119 | (body (flet-body form))) 120 | (%infer-flet bindings body nil tenv aenv uenv fenv fenv))) 121 | 122 | (defun %infer-flet (bindings body rec-p tenv aenv uenv fenv fenv1) 123 | (if bindings 124 | (destructuring-bind ((name args form) . bindings1) bindings 125 | (multiple-value-bind (ftype aenv1 uenv1) 126 | (infer-function name args form tenv aenv uenv fenv :rec-p rec-p) 127 | (let ((fenv2 (extend-funenv-function name nil ftype args fenv1)) 128 | (aenv2 (extend-appenv (car bindings) ftype aenv1))) 129 | (%infer-flet bindings1 body rec-p tenv aenv2 uenv1 fenv fenv2)))) 130 | (infer-form body tenv aenv uenv fenv1))) 131 | 132 | (defun infer-labels (form tenv aenv uenv fenv) 133 | (let ((bindings (labels-bindings form)) 134 | (body (labels-body form))) 135 | (%infer-flet bindings body t tenv aenv uenv fenv fenv))) 136 | 137 | (defun infer-setf (form tenv aenv uenv fenv) 138 | (let ((place (setf-place form)) 139 | (value (setf-value form))) 140 | (multiple-value-bind (type1 aenv1 uenv1) 141 | (infer-form place tenv aenv uenv fenv) 142 | (multiple-value-bind (type2 aenv2 uenv2) 143 | (infer-form value tenv aenv1 uenv1 fenv) 144 | (multiple-value-bind (type3 uenv3) (unify type1 type2 uenv2) 145 | (values type3 aenv2 uenv3)))))) 146 | 147 | (defun infer-apply (form tenv aenv uenv fenv) 148 | (flet ((aux (aenv-uenv argtype-operand) 149 | (destructuring-bind (aenv1 uenv1) aenv-uenv 150 | (destructuring-bind (argtype . operand) argtype-operand 151 | (multiple-value-bind (type aenv2 uenv2) 152 | (infer-form operand tenv aenv1 uenv1 fenv) 153 | (multiple-value-bind (_ uenv3) (unify argtype type uenv2) 154 | (declare (ignore _)) 155 | (list aenv2 uenv3))))))) 156 | (let ((operator (apply-operator form)) 157 | (operands (apply-operands form))) 158 | (let ((argc (if (built-in-exists-p operator) 159 | (built-in-argc operator) 160 | (funenv-function-argc operator fenv)))) 161 | (unless (= argc (length operands)) 162 | (error "Invalid number of arguments: ~S" (length operands)))) 163 | (let* ((type (if (built-in-exists-p operator) 164 | (type-scheme-to-type 165 | (built-in-type-scheme operator)) 166 | (funenv-function-type operator fenv))) 167 | (aenv1 (extend-appenv form type aenv))) 168 | (let ((argtypes (function-arg-types type)) 169 | (return-type (function-return-type type))) 170 | (destructuring-bind (aenv2 uenv1) 171 | (reduce #'aux (mapcar #'cons argtypes operands) 172 | :initial-value (list aenv1 uenv)) 173 | (let ((return-type1 (query-unienv return-type uenv1))) 174 | (values return-type1 aenv2 uenv1)))))))) 175 | -------------------------------------------------------------------------------- /src/lang/kernel.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.kernel 8 | (:use :cl 9 | :avm 10 | :avm.lang.symbol 11 | :avm.lang.type) 12 | (:shadow :function) 13 | (:import-from :alexandria 14 | :with-gensyms) 15 | (:export ;; Kernel 16 | :kernel 17 | :make-kernel 18 | :kernel-function-names 19 | :kernel-macro-names 20 | ;; Functions 21 | :kernel-define-function 22 | :kernel-function-exists-p 23 | :kernel-function-name 24 | :kernel-function-lisp-name 25 | :kernel-function-cuda-name 26 | :kernel-function-type 27 | :kernel-function-arguments 28 | :kernel-function-body 29 | ;; Macros 30 | :kernel-define-macro 31 | :kernel-macro-exists-p 32 | :kernel-macro-name 33 | :kernel-macro-arguments 34 | :kernel-macro-body 35 | :kernel-macro-expander 36 | ;; Globals 37 | ;; Constants 38 | ;; Symbol macros. 39 | )) 40 | (in-package :avm.lang.kernel) 41 | 42 | 43 | ;; 44 | ;; Functions 45 | 46 | (defstruct (function (:constructor %make-function)) 47 | (name :name :read-only t) 48 | (lisp-name :lisp-name :read-only t) 49 | (cuda-name :cuda-name :read-only t) 50 | (type :type :read-only t) 51 | (arguments :arguments :read-only t) 52 | (body :body :read-only t)) 53 | 54 | (defun make-function (name lisp-name cuda-name type arguments body) 55 | (check-type name avm-symbol) 56 | (check-type lisp-name symbol) 57 | (check-type cuda-name cl-cuda.lang.data:cl-cuda-symbol) 58 | (check-type type function-type) 59 | (loop for argument in arguments 60 | do (check-type argument avm-symbol)) 61 | (check-type body list) 62 | (unless (= (1- (length type)) (length arguments)) 63 | (error "Invalid number of arguments against type: ~S" (length arguments))) 64 | (%make-function :name name 65 | :lisp-name lisp-name 66 | :cuda-name cuda-name 67 | :type type 68 | :arguments arguments 69 | :body body)) 70 | 71 | 72 | ;; 73 | ;; Macros 74 | 75 | (defstruct (macro (:constructor %make-macro)) 76 | (name :name :read-only t) 77 | (arguments :arguments :read-only t) 78 | (body :body :read-only t) 79 | (expander :expander :read-only t)) 80 | 81 | (defun make-macro (name arguments body) 82 | (check-type name avm-symbol) 83 | (with-gensyms (arguments1) 84 | (let ((expander (eval `#'(lambda (,arguments1) 85 | (destructuring-bind ,arguments ,arguments1 86 | ,@body))))) 87 | (%make-macro :name name 88 | :arguments arguments 89 | :body body 90 | :expander expander)))) 91 | 92 | 93 | ;; 94 | ;; Globals 95 | 96 | (defstruct (global (:constructor %make-global)) 97 | (name :name :read-only t) 98 | (value :value :read-only t)) 99 | 100 | (defun make-global (name value) 101 | (check-type name avm-symbol) 102 | (%make-global :name name :value value)) 103 | 104 | 105 | ;; 106 | ;; Constants 107 | 108 | (defstruct (constant (:constructor %make-constant)) 109 | (name :name :read-only t) 110 | (value :value :read-only t)) 111 | 112 | (defun make-constant (name value) 113 | (check-type name avm-symbol) 114 | (%make-constant :name name :value value)) 115 | 116 | 117 | ;; 118 | ;; Symbol macros 119 | 120 | (defstruct (symbol-macro (:constructor %make-symbol-macro)) 121 | (name :name :read-only t) 122 | (expansion :expansion :read-only t)) 123 | 124 | (defun make-symbol-macro (name expansion) 125 | (check-type name avm-symbol) 126 | (%make-symbol-macro :name name :expansion expansion)) 127 | 128 | 129 | ;; 130 | ;; Kernel 131 | 132 | (defstruct (kernel (:constructor %make-kernel)) 133 | (variable-namespace :variable-namespace) 134 | (function-namespace :function-namespace)) 135 | 136 | (defun make-kernel () 137 | (%make-kernel :variable-namespace '() 138 | :function-namespace '())) 139 | 140 | (defun kernel-function-names (kernel) 141 | (let ((namespace (kernel-function-namespace kernel))) 142 | (nreverse 143 | (loop for (name entry) on namespace by #'cddr 144 | when (function-p entry) 145 | collect name)))) 146 | 147 | (defun kernel-macro-names (kernel) 148 | (let ((namespace (kernel-function-namespace kernel))) 149 | (nreverse 150 | (loop for (name entry) on namespace by #'cddr 151 | when (macro-p entry) 152 | collect name)))) 153 | 154 | 155 | ;; 156 | ;; Kernel - Functions 157 | 158 | (defun kernel-define-function (kernel name lisp-name cuda-name type args body) 159 | (symbol-macrolet ((namespace (kernel-function-namespace kernel))) 160 | (let ((function (make-function name lisp-name cuda-name type args body))) 161 | (setf (getf namespace name) function))) 162 | name) 163 | 164 | (defun kernel-function-exists-p (kernel name) 165 | (let ((namespace (kernel-function-namespace kernel))) 166 | (function-p (getf namespace name)))) 167 | 168 | (defun %lookup-function (kernel name) 169 | (unless (kernel-function-exists-p kernel name) 170 | (error "The function ~S is undefined." name)) 171 | (let ((namespace (kernel-function-namespace kernel))) 172 | (getf namespace name))) 173 | 174 | (defun kernel-function-name (kernel name) 175 | (function-name (%lookup-function kernel name))) 176 | 177 | (defun kernel-function-lisp-name (kernel name) 178 | (function-lisp-name (%lookup-function kernel name))) 179 | 180 | (defun kernel-function-cuda-name (kernel name) 181 | (function-cuda-name (%lookup-function kernel name))) 182 | 183 | (defun kernel-function-type (kernel name) 184 | (function-type (%lookup-function kernel name))) 185 | 186 | (defun kernel-function-arguments (kernel name) 187 | (function-arguments (%lookup-function kernel name))) 188 | 189 | (defun kernel-function-body (kernel name) 190 | (function-body (%lookup-function kernel name))) 191 | 192 | 193 | ;; 194 | ;; Kernel - Macros 195 | 196 | (defun kernel-define-macro (kernel name args body) 197 | (symbol-macrolet ((namespace (kernel-function-namespace kernel))) 198 | (let ((macro (make-macro name args body))) 199 | (setf (getf namespace name) macro))) 200 | name) 201 | 202 | (defun kernel-macro-exists-p (kernel name) 203 | (let ((namespace (kernel-function-namespace kernel))) 204 | (macro-p (getf namespace name)))) 205 | 206 | (defun %lookup-macro (kernel name) 207 | (unless (kernel-macro-exists-p kernel name) 208 | (error "The macro ~S is undefined." name)) 209 | (let ((namespace (kernel-function-namespace kernel))) 210 | (getf namespace name))) 211 | 212 | (defun kernel-macro-name (kernel name) 213 | (macro-name (%lookup-macro kernel name))) 214 | 215 | (defun kernel-macro-arguments (kernel name) 216 | (macro-arguments (%lookup-macro kernel name))) 217 | 218 | (defun kernel-macro-body (kernel name) 219 | (macro-body (%lookup-macro kernel name))) 220 | 221 | (defun kernel-macro-expander (kernel name) 222 | (macro-expander (%lookup-macro kernel name))) 223 | 224 | 225 | ;; 226 | ;; Kernel - Globals 227 | 228 | 229 | ;; 230 | ;; Kernel - Constants 231 | 232 | 233 | ;; 234 | ;; Kernel - Symbol Macros 235 | 236 | 237 | -------------------------------------------------------------------------------- /src/lang/lang.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang 8 | (:use :cl) 9 | (:export :compile-kernel-function 10 | :compile-kernel-global 11 | :compile-kernel-constant 12 | )) 13 | (in-package :avm.lang) 14 | 15 | 16 | ;; 17 | ;; Compiler top 18 | 19 | (defgeneric compile-kernel-function (engine name args body kernel)) 20 | 21 | (defgeneric compile-kernel-global (kernel name engine)) 22 | 23 | (defgeneric compile-kernel-constant (kernel name engine)) 24 | -------------------------------------------------------------------------------- /src/lang/symbol.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.symbol 8 | (:use :cl) 9 | (:export :avm-symbol 10 | :avm-symbol-p 11 | )) 12 | (in-package :avm.lang.symbol) 13 | 14 | 15 | ;; 16 | ;; Symbol 17 | 18 | (deftype avm-symbol () 19 | '(satisfies avm-symbol-p)) 20 | 21 | (defun avm-symbol-p (object) 22 | (symbolp object)) 23 | -------------------------------------------------------------------------------- /src/lang/syntax.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.syntax 8 | (:use :cl 9 | :avm 10 | :avm.lang.symbol 11 | :avm.lang.type) 12 | (:export ;; Literal 13 | :literal-p 14 | :int-literal-p 15 | :float-literal-p 16 | :double-literal-p 17 | ;; Reference 18 | :reference-p 19 | ;; Accessor 20 | :accessor-p 21 | :vector-accessor-p 22 | :array-accessor-p 23 | ;; THE 24 | :the-p 25 | :the-type 26 | :the-value 27 | ;; IF 28 | :if-p 29 | :if-test-form 30 | :if-then-form 31 | :if-else-form 32 | ;; LET 33 | :let-p 34 | :let-bindings 35 | :let-body 36 | :let-bindings% 37 | :let-body% 38 | ;; FLET 39 | :flet-p 40 | :flet-bindings 41 | :flet-body 42 | :flet-bindings% 43 | :flet-body% 44 | ;; LABELS 45 | :labels-p 46 | :labels-bindings 47 | :labels-body 48 | :labels-bindings% 49 | :labels-body% 50 | ;; SETF 51 | :setf-p 52 | :setf-place 53 | :setf-value 54 | ;; Place 55 | :place-p 56 | :reference-place-p 57 | :vector-place-p 58 | :vector-place-operator 59 | :vector-place-value 60 | :array-place-p 61 | :array-place-value 62 | :array-place-index 63 | ;; Application 64 | :apply-p 65 | :apply-operator 66 | :apply-operands 67 | )) 68 | (in-package :avm.lang.syntax) 69 | 70 | 71 | ;; 72 | ;; Literal 73 | 74 | (defun literal-p (object) 75 | (or (int-literal-p object) 76 | (float-literal-p object) 77 | (double-literal-p object))) 78 | 79 | (defun int-literal-p (object) 80 | (typep object 'fixnum)) 81 | 82 | (defun float-literal-p (object) 83 | (typep object 'single-float)) 84 | 85 | (defun double-literal-p (object) 86 | (typep object 'double-float)) 87 | 88 | 89 | ;; 90 | ;; Reference 91 | 92 | (defun reference-p (object) 93 | (avm-symbol-p object)) 94 | 95 | 96 | ;; 97 | ;; Accessor 98 | 99 | (defun accessor-p (object) 100 | (or (vector-accessor-p object) 101 | (array-accessor-p object))) 102 | 103 | (defun vector-accessor-p (object) 104 | (cl-pattern:match object 105 | ((op . _) 106 | (member op 107 | '(int2-x int2-y 108 | int3-x int3-y int3-z 109 | int4-x int4-y int4-z int4-w 110 | float2-x float2-y 111 | float3-x float3-y float3-z 112 | float4-x float4-y float4-z float4-w 113 | double2-x double2-y 114 | double3-x double3-y double3-z 115 | double4-x double4-y double4-z double4-w))) 116 | (_ nil))) 117 | 118 | (defun array-accessor-p (object) 119 | (cl-pattern:match object 120 | (('aref . _) t) 121 | (_ nil))) 122 | 123 | 124 | ;; 125 | ;; THE 126 | 127 | (defun the-p (object) 128 | (cl-pattern:match object 129 | (('the . _) t) 130 | (_ nil))) 131 | 132 | (defun the-type (form) 133 | (cl-pattern:match form 134 | (('the type _) type) 135 | (_ (error "The form ~S is malformed." form)))) 136 | 137 | (defun the-value (form) 138 | (cl-pattern:match form 139 | (('the _ value) value) 140 | (_ (error "The form ~S is malformed." form)))) 141 | 142 | 143 | ;; 144 | ;; IF 145 | 146 | (defun if-p (object) 147 | (cl-pattern:match object 148 | (('if . _) t) 149 | (_ nil))) 150 | 151 | (defun if-test-form (form) 152 | (cl-pattern:match form 153 | (('if test-form _ _) test-form) 154 | (_ (error "The form ~S is malformed." form)))) 155 | 156 | (defun if-then-form (form) 157 | (cl-pattern:match form 158 | (('if _ then-form _) then-form) 159 | (_ (error "The form ~S is malformed." form)))) 160 | 161 | (defun if-else-form (form) 162 | (cl-pattern:match form 163 | (('if _ _ else-form) else-form) 164 | (_ (error "The form ~S is malformed." form)))) 165 | 166 | 167 | ;; 168 | ;; LET 169 | 170 | (defun let-p (object) 171 | (cl-pattern:match object 172 | (('let . _) t) 173 | (_ nil))) 174 | 175 | (defun let-bindings (form) 176 | (cl-pattern:match form 177 | (('let bindings _) 178 | (unless (every #'binding-p bindings) 179 | (error "The form ~S is malformed." form)) 180 | (unless (null #1=(find-duplicate (mapcar #'car bindings))) 181 | (error "The variable ~A occurs more than once in the LET." #1#)) 182 | bindings) 183 | (_ (error "The form ~S is malformed." form)))) 184 | 185 | (defun binding-p (object) 186 | (cl-pattern:match object 187 | ((var _) (avm-symbol-p var)) 188 | (_ nil))) 189 | 190 | (defun find-duplicate (xs) 191 | (cond 192 | ((null xs) nil) 193 | ((member (car xs) (cdr xs)) (car xs)) 194 | (t (find-duplicate (cdr xs))))) 195 | 196 | (defun let-body (form) 197 | (cl-pattern:match form 198 | (('let _ body) body) 199 | (_ (error "The form ~S is malformed." form)))) 200 | 201 | (defun let-bindings% (form) 202 | (cl-pattern:match form 203 | (('let bindings . _) 204 | (unless (every #'binding-p bindings) 205 | (error "The form ~S is malformed." form)) 206 | (unless (null #1=(find-duplicate (mapcar #'car bindings))) 207 | (error "The variable ~A occurs more than once in the LET." #1#)) 208 | bindings) 209 | (_ (error "The form ~S is malformed." form)))) 210 | 211 | (defun let-body% (form) 212 | (cl-pattern:match form 213 | (('let _ . body) body) 214 | (_ (error "The form ~S is malformed." form)))) 215 | 216 | 217 | ;; 218 | ;; FLET 219 | 220 | (defun flet-p (object) 221 | (cl-pattern:match object 222 | (('flet . _) t) 223 | (_ nil))) 224 | 225 | (defun flet-bindings (form) 226 | (cl-pattern:match form 227 | (('flet bindings _) 228 | (unless (every #'fbinding-p bindings) 229 | (error "The form ~S is malformed." form)) 230 | (unless (not #1=(find-duplicate (mapcar #'car bindings))) 231 | (error "The function ~A occurs more than once in the FLET." #1#)) 232 | bindings) 233 | (_ (error "The form ~S is malformed." form)))) 234 | 235 | (defun fbinding-p (object) 236 | (cl-pattern:match object 237 | ((name args _) (and (avm-symbol-p name) 238 | (every #'avm-symbol-p args))) 239 | (_ nil))) 240 | 241 | (defun flet-body (form) 242 | (cl-pattern:match form 243 | (('flet _ body) body) 244 | (_ (error "The form ~S is malformed." form)))) 245 | 246 | (defun flet-bindings% (form) 247 | (cl-pattern:match form 248 | (('flet bindings . _) 249 | (unless (every #'fbinding-p% bindings) 250 | (error "The form ~S is malformed." form)) 251 | (unless (not #1=(find-duplicate (mapcar #'car bindings))) 252 | (error "The function ~A occurs more than once in the FLET." #1#)) 253 | bindings) 254 | (_ (error "The form ~S is malformed." form)))) 255 | 256 | (defun fbinding-p% (object) 257 | (cl-pattern:match object 258 | ((name args . _) (and (avm-symbol-p name) 259 | (every #'avm-symbol-p args))) 260 | (_ nil))) 261 | 262 | (defun flet-body% (form) 263 | (cl-pattern:match form 264 | (('flet _ . body) body) 265 | (_ (error "The form ~S is malformed." form)))) 266 | 267 | 268 | ;; 269 | ;; LABELS 270 | 271 | (defun labels-p (object) 272 | (cl-pattern:match object 273 | (('labels . _) t) 274 | (_ nil))) 275 | 276 | (defun labels-bindings (form) 277 | (cl-pattern:match form 278 | (('labels bindings _) 279 | (unless (every #'fbinding-p bindings) 280 | (error "The form ~S is malformed." form)) 281 | (unless (not #1=(find-duplicate (mapcar #'car bindings))) 282 | (error "The function ~A occurs more than once in the LABELS." #1#)) 283 | bindings) 284 | (_ (error "The form ~S is malformed." form)))) 285 | 286 | (defun labels-body (form) 287 | (cl-pattern:match form 288 | (('labels _ body) body) 289 | (_ (error "The form ~S is malformed." form)))) 290 | 291 | (defun labels-bindings% (form) 292 | (cl-pattern:match form 293 | (('labels bindings . _) 294 | (unless (every #'fbinding-p% bindings) 295 | (error "The form ~S is malformed." form)) 296 | (unless (not #1=(find-duplicate (mapcar #'car bindings))) 297 | (error "The function ~A occurs more than once in the LABELS." #1#)) 298 | bindings) 299 | (_ (error "The form ~S is malformed." form)))) 300 | 301 | (defun labels-body% (form) 302 | (cl-pattern:match form 303 | (('labels _ . body) body) 304 | (_ (error "The form ~S is malformed." form)))) 305 | 306 | 307 | ;; 308 | ;; SETF 309 | 310 | (defun setf-p (object) 311 | (cl-pattern:match object 312 | (('setf . _) t) 313 | (_ nil))) 314 | 315 | (defun setf-place (form) 316 | (cl-pattern:match form 317 | (('setf place _) 318 | (unless (place-p place) 319 | (error "The form ~S is malformed." form)) 320 | place) 321 | (_ (error "The form ~S is malformed." form)))) 322 | 323 | (defun setf-value (form) 324 | (cl-pattern:match form 325 | (('setf _ value) value) 326 | (_ (error "The form ~S is malformed." form)))) 327 | 328 | 329 | ;; 330 | ;; Place 331 | 332 | (defun place-p (object) 333 | (or (reference-place-p object) 334 | (vector-place-p object) 335 | (array-place-p object))) 336 | 337 | (defun reference-place-p (object) 338 | (reference-p object)) 339 | 340 | (defun vector-place-p (object) 341 | (cl-pattern:match object 342 | ((op . _) 343 | (member op 344 | '(int2-x int2-y 345 | int3-x int3-y int3-z 346 | int4-x int4-y int4-z int4-w 347 | float2-x float2-y 348 | float3-x float3-y float3-z 349 | float4-x float4-y float4-z float4-w 350 | double2-x double2-y 351 | double3-x double3-y double3-z 352 | double4-x double4-y double4-z double4-w))) 353 | (_ nil))) 354 | 355 | (defun vector-place-operator (place) 356 | (cl-pattern:match place 357 | ((operator _) operator) 358 | (_ (error "The form ~S is malformed." place)))) 359 | 360 | (defun vector-place-value (place) 361 | (cl-pattern:match place 362 | ((_ value) 363 | (unless (place-p value) 364 | (error "The form ~S is malformed." value)) 365 | value) 366 | (_ (error "The form ~S is malformed." place)))) 367 | 368 | (defun array-place-p (object) 369 | (cl-pattern:match object 370 | (('aref . _) t) 371 | (_ nil))) 372 | 373 | (defun array-place-value (place) 374 | (cl-pattern:match place 375 | (('aref value _) 376 | (unless (place-p value) 377 | (error "The form ~S is malformed." value)) 378 | value) 379 | (_ (error "The form ~S is malformed." place)))) 380 | 381 | (defun array-place-index (place) 382 | (cl-pattern:match place 383 | (('aref _ index) index) 384 | (_ (error "The form ~S is malformed." place)))) 385 | 386 | 387 | ;; 388 | ;; Application 389 | 390 | (defun apply-p (object) 391 | (cl-pattern:match object 392 | ((operator . _) 393 | (unless (avm-symbol-p operator) 394 | (error "Illegal function call: ~S" object)) 395 | t) 396 | (_ nil))) 397 | 398 | (defun apply-operator (form) 399 | (car form)) 400 | 401 | (defun apply-operands (form) 402 | (cdr form)) 403 | -------------------------------------------------------------------------------- /src/lang/type.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.type 8 | (:use :cl 9 | :avm 10 | :avm.lang.symbol) 11 | (:export ;; Type 12 | :avm-type 13 | :avm-type-p 14 | :scalar-type-p 15 | :vector-type-p 16 | :vector-type-base-type 17 | :vector-type-size 18 | :array-type-p 19 | :array-type-base-type 20 | :type-variable-p 21 | :type-wildcard-p 22 | ;; Type of functions 23 | :function-type 24 | :function-type-p 25 | :make-function-type 26 | :function-arg-types 27 | :function-return-type 28 | ;; Parse 29 | :parse-type 30 | :unparse-type 31 | ;; Gentype 32 | :gentype 33 | :*gentype-counter* 34 | ;; Type scheme 35 | :type-scheme 36 | :type-scheme-p 37 | ;; Type scheme to type 38 | :type-scheme-to-type 39 | )) 40 | (in-package :avm.lang.type) 41 | 42 | 43 | ;; 44 | ;; Type 45 | 46 | (deftype avm-type () 47 | '(satisfies avm-type-p)) 48 | 49 | (defun avm-type-p (object) 50 | (or (scalar-type-p object) 51 | (vector-type-p object) 52 | (array-type-p object) 53 | (type-variable-p object))) 54 | 55 | (defun scalar-type-p (object) 56 | (and (member object '(bool int float double)) 57 | t)) 58 | 59 | (defun vector-type-p (object) 60 | (cl-pattern:match object 61 | ((:vector object1 size) 62 | (and (or (scalar-type-p object1) 63 | (type-variable-p object1)) 64 | (vector-type-size-p size))) 65 | (_ nil))) 66 | 67 | (defun vector-type-size-p (object) 68 | (or (type-variable-p object) 69 | (type-wildcard-p object) 70 | (and (integerp object) 71 | (<= 2 object 4)))) 72 | 73 | (defun vector-type-base-type (type) 74 | (assert (vector-type-p type)) 75 | (cl-pattern:match type 76 | ((:vector base-type _) base-type))) 77 | 78 | (defun vector-type-size (type) 79 | (assert (vector-type-p type)) 80 | (cl-pattern:match type 81 | ((:vector _ size) size))) 82 | 83 | (defun array-type-p (object) 84 | (cl-pattern:match object 85 | ((:array base-type) (or (scalar-type-p base-type) 86 | (vector-type-p base-type) 87 | (type-variable-p base-type))) 88 | (_ nil))) 89 | 90 | (defun array-type-base-type (type) 91 | (assert (array-type-p type)) 92 | (cl-pattern:match type 93 | ((:array base-type) base-type))) 94 | 95 | (defun type-variable-p (object) 96 | (and (cl-unification:variablep object) 97 | (not (type-wildcard-p object)))) 98 | 99 | (defun type-wildcard-p (object) 100 | (and (avm-symbol-p object) 101 | (string= object "_"))) 102 | 103 | 104 | ;; 105 | ;; Type of functions 106 | 107 | (deftype function-type () 108 | '(satisfies function-type-p)) 109 | 110 | (defun function-type-p (type) 111 | (and (listp type) 112 | (every #'avm-type-p type))) 113 | 114 | (defun make-function-type (arg-types return-type) 115 | (dolist (arg-type arg-types) 116 | (check-type arg-type avm-type)) 117 | (check-type return-type avm-type) 118 | (append arg-types (list return-type))) 119 | 120 | (defun function-arg-types (function-type) 121 | (butlast function-type)) 122 | 123 | (defun function-return-type (function-type) 124 | (car (last function-type))) 125 | 126 | 127 | ;; 128 | ;; Parse type 129 | 130 | (defun parse-type (type) 131 | (ecase type 132 | (int 'int) 133 | (int2 '(:vector int 2)) 134 | (int3 '(:vector int 3)) 135 | (int4 '(:vector int 4)) 136 | (float 'float) 137 | (float2 '(:vector float 2)) 138 | (float3 '(:vector float 3)) 139 | (float4 '(:vector float 4)) 140 | (double 'double) 141 | (double2 '(:vector double 2)) 142 | (double3 '(:vector double 3)) 143 | (double4 '(:vector double 4)))) 144 | 145 | (defun unparse-type (type) 146 | (cl-pattern:match type 147 | ('int 'int) 148 | ('float 'float) 149 | ('double 'double) 150 | ((:vector 'int 2) 'int2) 151 | ((:vector 'int 3) 'int3) 152 | ((:vector 'int 4) 'int4) 153 | ((:vector 'float 2) 'float2) 154 | ((:vector 'float 3) 'float3) 155 | ((:vector 'float 4) 'float4) 156 | ((:vector 'double 2) 'double2) 157 | ((:vector 'double 3) 'double3) 158 | ((:vector 'double 4) 'double4) 159 | ((:array _) (error "Not implemented.")) 160 | (_ (error "The value ~S is an invalid type." type)))) 161 | 162 | 163 | ;; 164 | ;; Gentype 165 | 166 | (defvar *gentype-counter* 0) 167 | 168 | (defun gentype () 169 | (prog1 (intern (format nil "?T~A" *gentype-counter*)) 170 | (incf *gentype-counter*))) 171 | 172 | 173 | ;; 174 | ;; Type scheme 175 | 176 | (deftype type-scheme () 177 | '(satisfies type-scheme-p)) 178 | 179 | (defun type-scheme-p (object) 180 | (cl-pattern:match object 181 | ((:type-scheme . objects) (every #'type-symbol-p objects)) 182 | (_ nil))) 183 | 184 | (defun type-symbol-p (object) 185 | (or (scalar-type-symbol-p object) 186 | (vector-type-symbol-p object) 187 | (array-type-symbol-p object))) 188 | 189 | (defun scalar-type-symbol-p (object) 190 | (or (scalar-type-p object) 191 | (type-scheme-variable-p object))) 192 | 193 | (defun vector-type-symbol-p (object) 194 | (cl-pattern:match object 195 | ((:vector base-type size) 196 | (and (scalar-type-symbol-p base-type) 197 | (vector-type-symbol-size-p size))) 198 | (_ nil))) 199 | 200 | (defun vector-type-symbol-size-p (object) 201 | (or (type-scheme-variable-p object) 202 | (type-wildcard-p object) 203 | (and (integerp object) 204 | (<= 2 object 4)))) 205 | 206 | (defun array-type-symbol-p (object) 207 | (cl-pattern:match object 208 | ((:array base-type) 209 | (or (scalar-type-symbol-p base-type) 210 | (vector-type-symbol-p base-type))) 211 | (_ nil))) 212 | 213 | (defun type-scheme-variable-p (object) 214 | (and (avm-symbol-p object) 215 | (not (type-variable-p object)) 216 | (not (type-wildcard-p object)))) 217 | 218 | 219 | ;; 220 | ;; Type scheme to type 221 | 222 | (defun type-scheme-to-type (type-scheme) 223 | (flet ((aux (types-dict type-symbol) 224 | (destructuring-bind (types dict) types-dict 225 | (multiple-value-bind (type dict1) 226 | (type-symbol-to-type type-symbol dict) 227 | (let ((types1 (cons type types))) 228 | (list types1 dict1)))))) 229 | (check-type type-scheme type-scheme) 230 | (cl-pattern:match type-scheme 231 | ((:type-scheme . type-symbols) 232 | (nreverse 233 | (car 234 | (reduce #'aux type-symbols :initial-value '(nil nil)))))))) 235 | 236 | (defun type-symbol-to-type (type-symbol dict) 237 | (cond 238 | ((scalar-type-symbol-p type-symbol) 239 | (scalar-type-symbol-to-type type-symbol dict)) 240 | ((vector-type-symbol-p type-symbol) 241 | (vector-type-symbol-to-type type-symbol dict)) 242 | ((array-type-symbol-p type-symbol) 243 | (array-type-symbol-to-type type-symbol dict)) 244 | (t (error "Must not be reached.")))) 245 | 246 | (defun scalar-type-symbol-to-type (type-symbol dict) 247 | (if (scalar-type-p type-symbol) 248 | (values type-symbol dict) 249 | (let ((type-symbol1 (cdr (assoc type-symbol dict)))) 250 | (if type-symbol1 251 | (values type-symbol1 dict) 252 | (let* ((type-symbol2 (gentype)) 253 | (dict1 (acons type-symbol type-symbol2 dict))) 254 | (values type-symbol2 dict1)))))) 255 | 256 | (defun vector-type-symbol-to-type (type-symbol dict) 257 | (cl-pattern:match type-symbol 258 | ((:vector base-type size) 259 | (multiple-value-bind (base-type1 dict1) 260 | (scalar-type-symbol-to-type base-type dict) 261 | (multiple-value-bind (size1 dict2) 262 | (vector-type-symbol-size-to-type size dict1) 263 | (values `(:vector ,base-type1 ,size1) dict2)))))) 264 | 265 | (defun vector-type-symbol-size-to-type (size dict) 266 | (cond 267 | ((type-scheme-variable-p size) 268 | (let ((size1 (cdr (assoc size dict)))) 269 | (if size1 270 | (values size1 dict) 271 | (let* ((size2 (gentype)) 272 | (dict1 (acons size size2 dict))) 273 | (values size2 dict1))))) 274 | ((type-wildcard-p size) (values size dict)) 275 | ((integerp size) (values size dict)) 276 | (t (error "Must not be reached.")))) 277 | 278 | (defun array-type-symbol-to-type (type-symbol dict) 279 | (cl-pattern:match type-symbol 280 | ((:array base-type) 281 | (multiple-value-bind (base-type1 dict1) 282 | (type-symbol-to-type base-type dict) 283 | (values `(:array ,base-type1) dict1))))) 284 | -------------------------------------------------------------------------------- /src/lang/typenv.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.typenv 8 | (:use :cl 9 | :avm.lang.symbol 10 | :avm.lang.type 11 | :avm.lang.unienv) 12 | (:export :empty-typenv 13 | :extend-typenv 14 | :query-typenv 15 | :subst-typenv)) 16 | (in-package :avm.lang.typenv) 17 | 18 | 19 | ;; 20 | ;; Type environment 21 | 22 | (defun empty-typenv () 23 | nil) 24 | 25 | (defun extend-typenv (var type tenv) 26 | (check-type var avm-symbol) 27 | (check-type type avm-type) 28 | (acons var type tenv)) 29 | 30 | (defun query-typenv (var tenv) 31 | (or (cdr (assoc var tenv)) 32 | (error "The variable ~S not found." var))) 33 | 34 | (defun subst-typenv (uenv tenv) 35 | (loop for (var . type) in tenv 36 | collect 37 | (let ((type1 (query-unienv type uenv))) 38 | (cons var type1)))) 39 | -------------------------------------------------------------------------------- /src/lang/unienv.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm.lang.unienv 8 | (:use :cl 9 | :avm.lang.type) 10 | (:import-from :cl-unification 11 | :make-empty-environment 12 | :find-variable-value) 13 | (:export :empty-unienv 14 | :query-unienv 15 | :unify)) 16 | (in-package :avm.lang.unienv) 17 | 18 | 19 | ;; 20 | ;; Unification environment 21 | 22 | (defun empty-unienv () 23 | (list nil nil (make-empty-environment))) 24 | 25 | (defun query-unienv (type uenv) 26 | (check-type type avm-type) 27 | (cond 28 | ((scalar-type-p type) type) 29 | ((vector-type-p type) 30 | (let ((base-type (vector-type-base-type type)) 31 | (size (vector-type-size type))) 32 | (let ((base-type1 (query-unienv base-type uenv)) 33 | (size1 (%query-unienv size uenv))) 34 | `(:vector ,base-type1 ,size1)))) 35 | ((array-type-p type) 36 | (let ((base-type (array-type-base-type type))) 37 | (let ((base-type1 (query-unienv base-type uenv))) 38 | `(:array ,base-type1)))) 39 | ((type-variable-p type) 40 | (destructuring-bind (lhs rhs subst) uenv 41 | (declare (ignore lhs rhs)) 42 | (let ((type1 (find-variable-value type subst))) 43 | (if type1 44 | (query-unienv type1 uenv) 45 | type)))) 46 | (t (error "Must not be reached.")))) 47 | 48 | (defun %query-unienv (size uenv) 49 | (assert (avm.lang.type::vector-type-size-p size)) 50 | (if (type-variable-p size) 51 | (destructuring-bind (lhs rhs subst) uenv 52 | (declare (ignore lhs rhs)) 53 | (let ((size1 (find-variable-value size subst))) 54 | (if size1 55 | (%query-unienv size1 uenv) 56 | size))) 57 | size)) 58 | 59 | (defun unify (type1 type2 uenv) 60 | (check-type type1 avm-type) 61 | (check-type type2 avm-type) 62 | (destructuring-bind (lhs rhs subst) uenv 63 | (let* ((lhs1 (cons type1 lhs)) 64 | (rhs1 (cons type2 rhs)) 65 | (subst1 (cl-unification:unify lhs1 rhs1 subst))) 66 | (let* ((uenv1 (list lhs1 rhs1 subst1)) 67 | (type (query-unienv type1 uenv1))) 68 | (values type uenv1))))) 69 | -------------------------------------------------------------------------------- /t/api/array.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test.api.array 8 | (:use :cl 9 | :prove 10 | :avm 11 | :avm.api.array)) 12 | (in-package :avm-test.api.array) 13 | 14 | 15 | (plan nil) 16 | 17 | 18 | ;; 19 | ;; Array 20 | 21 | (subtest "array-cuda-available-on-allocation-p" 22 | 23 | (with-cuda (0) 24 | (with-array (xs int 1) 25 | (ok (avm.api.array::array-cuda-available-on-allocation-p xs) 26 | "CUDA available on allocation."))) 27 | 28 | (with-array (xs int 1) 29 | (ok (not (avm.api.array::array-cuda-available-on-allocation-p xs)) 30 | "CUDA not available on allocation."))) 31 | 32 | (subtest "array-freed-p" 33 | 34 | (let ((xs (alloc-array 'int 1))) 35 | (ok (not (avm.api.array::array-freed-p xs))) 36 | (free-array xs) 37 | (ok (avm.api.array::array-freed-p xs))) 38 | 39 | (with-cuda (0) 40 | (let ((xs (alloc-array 'int 1))) 41 | (ok (not (avm.api.array::array-freed-p xs))) 42 | (free-array xs) 43 | (ok (avm.api.array::array-freed-p xs))))) 44 | 45 | (subtest "check-cuda-available" 46 | 47 | (with-cuda (0) 48 | (ok (null (avm.api.array::check-cuda-available)) 49 | "CUDA available.")) 50 | 51 | (is-error (avm.api.array::check-cuda-available) 52 | simple-error 53 | "CUDA not available.")) 54 | 55 | (subtest "check-array-cuda-available-on-allocation" 56 | 57 | (with-cuda (0) 58 | (with-array (xs int 1) 59 | (ok (null (avm.api.array::check-array-cuda-available-on-allocation xs)) 60 | "CUDA available on array allocation."))) 61 | 62 | (with-array (xs int 1) 63 | (is-error (avm.api.array::check-array-cuda-available-on-allocation xs) 64 | simple-error 65 | "CUDA not available on array allocation."))) 66 | 67 | (subtest "check-array-not-freed" 68 | 69 | (let ((xs (alloc-array 'int 1))) 70 | (ok (null (avm.api.array::check-array-not-freed xs)) 71 | "Array not freed.")) 72 | 73 | (let ((xs (alloc-array 'int 1))) 74 | (free-array xs) 75 | (is-error (avm.api.array::check-array-not-freed xs) 76 | simple-error 77 | "Array already freed."))) 78 | 79 | (subtest "array-tuple-array" 80 | 81 | (with-array (xs int 1) 82 | (ok (avm.api.array::array-tuple-array xs) 83 | "Tuple array in array not freed.")) 84 | 85 | (let ((xs (alloc-array 'int 1))) 86 | (free-array xs) 87 | (is-error (avm.api.array::array-tuple-array xs) 88 | simple-error 89 | "Tuple array in array freed."))) 90 | 91 | (subtest "array-host-ptr" 92 | 93 | (with-cuda (0) 94 | (with-array (xs int 1) 95 | (ok (avm.api.array::array-host-ptr xs) 96 | "Host pointer."))) 97 | 98 | (with-array (xs int 1) 99 | (is-error (avm.api.array::array-host-ptr xs) 100 | simple-error 101 | "CUDA not available.")) 102 | 103 | (with-array (xs int 1) 104 | (with-cuda (0) 105 | (is-error (avm.api.array::array-host-ptr xs) 106 | simple-error 107 | "CUDA not available on allocation."))) 108 | 109 | (with-cuda (0) 110 | (let ((xs (alloc-array 'int 1))) 111 | (free-array xs) 112 | (is-error (avm.api.array::array-host-ptr xs) 113 | simple-error 114 | "Array already freed."))) 115 | 116 | (is-error (avm.api.array::array-host-ptr :foo) 117 | type-error 118 | "Invalid array.")) 119 | 120 | (subtest "array-device-ptr" 121 | 122 | (with-cuda (0) 123 | (with-array (xs int 1) 124 | (ok (avm.api.array::array-device-ptr xs) 125 | "Device pointer."))) 126 | 127 | (with-array (xs int 1) 128 | (is-error (avm.api.array::array-device-ptr xs) 129 | simple-error 130 | "CUDA not available.")) 131 | 132 | (with-array (xs int 1) 133 | (with-cuda (0) 134 | (is-error (avm.api.array::array-device-ptr xs) 135 | simple-error 136 | "CUDA not available on allocation."))) 137 | 138 | (with-cuda (0) 139 | (let ((xs (alloc-array 'int 1))) 140 | (free-array xs) 141 | (is-error (avm.api.array::array-device-ptr xs) 142 | simple-error 143 | "Array already freed."))) 144 | 145 | (is-error (avm.api.array::array-device-ptr :foo) 146 | type-error 147 | "Invalid array.")) 148 | 149 | (subtest "array-lisp-up-to-date-p" 150 | 151 | (with-cuda (0) 152 | (with-array (xs int 1) 153 | (ok (eq t (avm.api.array::array-lisp-up-to-date-p xs)) 154 | "Lisp memory in array up-to-date."))) 155 | 156 | (with-array (xs int 1) 157 | (is-error (avm.api.array::array-lisp-up-to-date-p xs) 158 | simple-error 159 | "CUDA not available.")) 160 | 161 | (with-array (xs int 1) 162 | (with-cuda (0) 163 | (is-error (avm.api.array::array-lisp-up-to-date-p xs) 164 | simple-error 165 | "CUDA not available on allocation."))) 166 | 167 | (with-cuda (0) 168 | (let ((xs (alloc-array 'int 1))) 169 | (free-array xs) 170 | (is-error (avm.api.array::array-lisp-up-to-date-p xs) 171 | simple-error 172 | "Array already freed."))) 173 | 174 | (is-error (avm.api.array::array-lisp-up-to-date-p :foo) 175 | type-error 176 | "Invalid array.")) 177 | 178 | (subtest "array-cuda-up-to-date-p" 179 | 180 | (with-cuda (0) 181 | (with-array (xs int 1) 182 | (ok (eq t (avm.api.array::array-cuda-up-to-date-p xs)) 183 | "CUDA memory in array up-to-date."))) 184 | 185 | (with-array (xs int 1) 186 | (is-error (avm.api.array::array-cuda-up-to-date-p xs) 187 | simple-error 188 | "CUDA not available.")) 189 | 190 | (with-array (xs int 1) 191 | (with-cuda (0) 192 | (is-error (avm.api.array::array-cuda-up-to-date-p xs) 193 | simple-error 194 | "CUDA not available on allocation."))) 195 | 196 | (with-cuda (0) 197 | (let ((xs (alloc-array 'int 1))) 198 | (free-array xs) 199 | (is-error (avm.api.array::array-cuda-up-to-date-p xs) 200 | simple-error 201 | "Array already freed."))) 202 | 203 | (is-error (avm.api.array::array-cuda-up-to-date-p :foo) 204 | type-error 205 | "Invalid array.")) 206 | 207 | (subtest "alloc-array" 208 | 209 | (with-cuda (0) 210 | (with-array (xs int 1) 211 | (ok (and (avm.api.array::array-%tuple-array xs) 212 | (avm.api.array::array-%host-ptr xs) 213 | (avm.api.array::array-%device-ptr xs) 214 | (eql t (avm.api.array::array-%lisp-up-to-date xs)) 215 | (eql t (avm.api.array::array-%cuda-up-to-date xs))) 216 | "Array allocated with CUDA available."))) 217 | 218 | (with-array (xs int 1) 219 | (ok (and (avm.api.array::array-%tuple-array xs) 220 | (null (avm.api.array::array-%host-ptr xs)) 221 | (null (avm.api.array::array-%device-ptr xs)) 222 | (eql :%lisp-up-to-date 223 | (avm.api.array::array-%lisp-up-to-date xs)) 224 | (eql :%cuda-up-to-date 225 | (avm.api.array::array-%cuda-up-to-date xs))) 226 | "Array allocated with CUDA not available.")) 227 | 228 | (with-array (xs int 1) 229 | (is (array-base-type xs) 230 | 'int 231 | "Base type int."))) 232 | 233 | (subtest "free-array" 234 | 235 | ;; CUDA-AVAILABLE-P : T 236 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : T 237 | ;; ARRAY-FREED-P : NIL 238 | (with-cuda (0) 239 | (let ((xs (alloc-array 'int 1))) 240 | (free-array xs) 241 | (ok (and (null (avm.api.array::array-%tuple-array xs)) 242 | (cffi:null-pointer-p (avm.api.array::array-%host-ptr xs)) 243 | (= 0 (avm.api.array::array-%device-ptr xs)) 244 | (eql :%lisp-up-to-date 245 | (avm.api.array::array-%lisp-up-to-date xs)) 246 | (eql :%cuda-up-to-date 247 | (avm.api.array::array-%cuda-up-to-date xs))) 248 | "Free array CUDA availabe on allocation with CUDA availabe."))) 249 | 250 | ;; CUDA-AVAILABLE-P : NIL 251 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : T 252 | ;; ARRAY-FREED-P : NIL 253 | (let (xs) 254 | (with-cuda (0) 255 | (setf xs (alloc-array 'int 1))) 256 | (is-error 257 | (free-array xs) 258 | simple-error 259 | "Not free array CUDA availabe on allocation with not CUDA availabe.")) 260 | 261 | ;; CUDA-AVAILABLE-P : T 262 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : NIL 263 | ;; ARRAY-FREED-P : NIL 264 | (let ((xs (alloc-array 'int 1))) 265 | (with-cuda (0) 266 | (free-array xs)) 267 | (ok (and (null (avm.api.array::array-%tuple-array xs)) 268 | (null (avm.api.array::array-%host-ptr xs)) 269 | (null (avm.api.array::array-%device-ptr xs)) 270 | (eql :%lisp-up-to-date 271 | (avm.api.array::array-%lisp-up-to-date xs)) 272 | (eql :%cuda-up-to-date 273 | (avm.api.array::array-%cuda-up-to-date xs))) 274 | "Free array CUDA not availabe on allocation with CUDA availabe.")) 275 | 276 | ;; CUDA-AVAILABLE-P : NIL 277 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : NIL 278 | ;; ARRAY-FREED-P : NIL 279 | (let ((xs (alloc-array 'int 1))) 280 | (free-array xs) 281 | (ok (and (null (avm.api.array::array-%tuple-array xs)) 282 | (null (avm.api.array::array-%host-ptr xs)) 283 | (null (avm.api.array::array-%device-ptr xs)) 284 | (eql :%lisp-up-to-date 285 | (avm.api.array::array-%lisp-up-to-date xs)) 286 | (eql :%cuda-up-to-date 287 | (avm.api.array::array-%cuda-up-to-date xs))) 288 | "Free array not CUDA availabe on allocation with not CUDA availabe.")) 289 | 290 | ;; CUDA-AVAILABLE-P : any 291 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : any 292 | ;; ARRAY-FREED-P : T 293 | (let ((xs (alloc-array 'int 1))) 294 | (free-array xs) 295 | (ok (null (free-array xs)) 296 | "Array already freed.")) 297 | 298 | (is-error (free-array :foo) 299 | type-error 300 | "Invalid array.")) 301 | 302 | (defkernel fill-ones (xs) 303 | (setf (aref xs i) 1)) 304 | 305 | (subtest "array-aref" 306 | 307 | ;; CUDA-AVAILABLE-P : T 308 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : T 309 | ;; ARRAY-FREED-P : NIL 310 | (with-cuda (0) 311 | (with-array (xs int 1) 312 | (setf (array-aref xs 0) 0) 313 | (fill-ones xs) 314 | (is (array-aref xs 0) 315 | 1 316 | "Array CUDA availabe on allocation with CUDA availabe."))) 317 | 318 | ;; CUDA-AVAILABLE-P : NIL 319 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : T 320 | ;; ARRAY-FREED-P : NIL 321 | (let (xs) 322 | (with-cuda (0) 323 | (setf xs (alloc-array 'int 1))) 324 | (is-error (array-aref xs 0) 325 | simple-error 326 | "Array CUDA availabe on allocation with not CUDA availabe.")) 327 | 328 | ;; CUDA-AVAILABLE-P : T 329 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : NIL 330 | ;; ARRAY-FREED-P : NIL 331 | (with-array (xs int 1) 332 | (with-cuda (0) 333 | (is-error (array-aref xs 0) 334 | simple-error 335 | "Array not CUDA availabe on allocation with CUDA availabe."))) 336 | 337 | ;; CUDA-AVAILABLE-P : NIL 338 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : NIL 339 | ;; ARRAY-FREED-P : NIL 340 | (with-array (xs int 1) 341 | (setf (array-aref xs 0) 1) 342 | (is (array-aref xs 0) 343 | 1 344 | "Array not CUDA availabe on allocation with not CUDA availabe.")) 345 | 346 | ;; CUDA-AVAILABLE-P : any 347 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : any 348 | ;; ARRAY-FREED-P : T 349 | (let (xs) 350 | (setf xs (alloc-array 'int 1)) 351 | (free-array xs) 352 | (is-error (array-aref xs 0) 353 | simple-error 354 | "Array already freed.")) 355 | 356 | (is-error (array-aref :foo 0) 357 | type-error 358 | "Invalid array.") 359 | 360 | (with-array (xs int 1) 361 | (is-error (array-aref xs :foo) 362 | error 363 | "Invalid index."))) 364 | 365 | (subtest "setf array-aref" 366 | 367 | ;; CUDA-AVAILABLE-P : T 368 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : T 369 | ;; ARRAY-FREED-P : NIL 370 | (with-cuda (0) 371 | (with-array (xs int 1) 372 | (fill-ones xs) 373 | (setf (array-aref xs 0) 2) 374 | (is (array-aref xs 0) 375 | 2) 376 | (ok (avm.api.array::array-%lisp-up-to-date xs)) 377 | (ok (not (avm.api.array::array-%cuda-up-to-date xs))))) 378 | 379 | ;; CUDA-AVAILABLE-P : NIL 380 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : T 381 | ;; ARRAY-FREED-P : NIL 382 | (let (xs) 383 | (with-cuda (0) 384 | (setf xs (alloc-array 'int 1))) 385 | (is-error (setf (array-aref xs 0) 1) 386 | simple-error 387 | "Array CUDA availabe on allocation with not CUDA availabe.")) 388 | 389 | ;; CUDA-AVAILABLE-P : T 390 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : NIL 391 | ;; ARRAY-FREED-P : NIL 392 | (with-array (xs int 1) 393 | (with-cuda (0) 394 | (is-error (setf (array-aref xs 0) 1) 395 | simple-error 396 | "Array not CUDA availabe on allocation with CUDA availabe."))) 397 | 398 | ;; CUDA-AVAILABLE-P : NIL 399 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : NIL 400 | ;; ARRAY-FREED-P : NIL 401 | (with-array (xs int 1) 402 | (setf (array-aref xs 0) 1) 403 | (is (array-aref xs 0) 404 | 1 405 | "Array not CUDA availabe on allocation with not CUDA availabe.")) 406 | 407 | ;; CUDA-AVAILABLE-P : any 408 | ;; ARRAY-CUDA-AVAILABLE-ON-ALLOCATION-P : any 409 | ;; ARRAY-FREED-P : T 410 | (let (xs) 411 | (setf xs (alloc-array 'int 1)) 412 | (free-array xs) 413 | (is-error (setf (array-aref xs 0) 1) 414 | simple-error 415 | "Array already freed.")) 416 | 417 | (with-array (xs int 1) 418 | (is-error (array-aref xs :foo) 419 | error 420 | "Invalid index."))) 421 | 422 | (subtest "array-size" 423 | 424 | (with-array (xs int 100) 425 | (is (array-size xs) 426 | 100)) 427 | 428 | (let (xs) 429 | (setf xs (alloc-array 'int 100)) 430 | (free-array xs) 431 | (is-error (array-size xs) 432 | simple-error 433 | "Array already freed."))) 434 | 435 | (subtest "sync-array" 436 | 437 | (with-cuda (0) 438 | (with-arrays ((xs float4 (* 1024 1024)) 439 | (ys float4 (* 1024 1024))) 440 | ;; Initialize array. 441 | (dotimes (i (array-size xs)) 442 | (setf (array-aref xs i) 443 | (values (random 1.0) (random 1.0) (random 1.0) (random 1.0)))) 444 | ;; Copy to another for verification. 445 | (dotimes (i (array-size xs)) 446 | (setf (array-aref ys i) (array-aref xs i))) 447 | ;; Synchroize from Lisp to CUDA. 448 | (avm.api.array::sync-array xs :lisp :cuda) 449 | ;; Clear array. 450 | (dotimes (i (array-size xs)) 451 | (setf (array-aref xs i) (values 0.0 0.0 0.0 0.0))) 452 | ;; Synchroize back from CUDA to Lisp. 453 | (avm.api.array::sync-array xs :cuda :lisp) 454 | ;; Verify arrays. 455 | (dotimes (i (array-size xs)) 456 | (assert (= (array-aref ys i) (array-aref xs i)))) 457 | (ok t))) 458 | ) 459 | 460 | (subtest "array-ensure-lisp-up-to-date" 461 | 462 | (with-cuda (0) 463 | (with-array (xs int 1) 464 | (array-ensure-lisp-up-to-date xs) 465 | (ok (avm.api.array::array-lisp-up-to-date-p xs) 466 | "Lisp memory is up-to-date."))) 467 | 468 | (with-cuda (0) 469 | (with-array (xs int 1) 470 | (array-set-cuda-dirty xs) 471 | (array-ensure-lisp-up-to-date xs) 472 | (ok (avm.api.array::array-lisp-up-to-date-p xs) 473 | "Lisp memory is not up-to-date, device memory is."))) 474 | 475 | (with-cuda (0) 476 | (is-error (array-ensure-lisp-up-to-date :foo) 477 | type-error 478 | "Invalid array.")) 479 | 480 | (with-cuda (0) 481 | (with-array (xs int 1) 482 | (setf (avm.api.array::array-%lisp-up-to-date xs) nil) 483 | (setf (avm.api.array::array-%cuda-up-to-date xs) nil) 484 | (is-error (array-ensure-lisp-up-to-date xs) 485 | simple-error 486 | "Lisp memory is up-to-date, device memory is not."))) 487 | ) 488 | 489 | (subtest "array-ensure-cuda-up-to-date" 490 | 491 | (with-cuda (0) 492 | (with-array (xs int 1) 493 | (array-ensure-cuda-up-to-date xs) 494 | (ok (avm.api.array::array-%cuda-up-to-date xs) 495 | "Device memory is up-to-date."))) 496 | 497 | (with-cuda (0) 498 | (with-array (xs int 1) 499 | (array-set-lisp-dirty xs) 500 | (array-ensure-cuda-up-to-date xs) 501 | (ok (avm.api.array::array-%cuda-up-to-date xs) 502 | "Device memory is not up-to-date, Lisp memory is."))) 503 | 504 | (is-error (array-ensure-cuda-up-to-date :foo) 505 | type-error 506 | "Invalid array.") 507 | 508 | (with-cuda (0) 509 | (with-array (xs int 1) 510 | (setf (avm.api.array::array-%lisp-up-to-date xs) nil) 511 | (setf (avm.api.array::array-%cuda-up-to-date xs) nil) 512 | (is-error (array-ensure-cuda-up-to-date xs) 513 | simple-error 514 | "Device memory is not up-to-date, Lisp memory is not."))) 515 | ) 516 | 517 | 518 | (finalize) 519 | -------------------------------------------------------------------------------- /t/api/cuda.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test.api.cuda 8 | (:use :cl 9 | :prove 10 | :avm 11 | :avm.api.cuda)) 12 | (in-package :avm-test.api.cuda) 13 | 14 | 15 | (plan nil) 16 | 17 | (subtest "CUDA state" 18 | 19 | (let ((cl-cuda:*sdk-not-found*)) ; fake CUDA not available 20 | (with-cuda (nil) 21 | (ok (cuda-state-not-available-p) 22 | "CUDA is not available."))) 23 | 24 | (with-cuda (nil) 25 | (ok (cuda-state-not-available-p) 26 | "CUDA state \"Not available\".")) 27 | 28 | (with-cuda (0) 29 | (ok (cuda-state-used-p) 30 | "CUDA state \"Used\".") 31 | (let ((*use-cuda-p* nil)) 32 | (ok (cuda-state-available-p) 33 | "CUDA state \"Available\""))) 34 | 35 | ) 36 | 37 | (finalize) 38 | -------------------------------------------------------------------------------- /t/api/macro.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test.api.macro 8 | (:use :cl 9 | :prove 10 | :avm 11 | :avm.api.macro 12 | :avm-test.util)) 13 | (in-package :avm-test.api.macro) 14 | 15 | 16 | (plan nil) 17 | 18 | 19 | ;; 20 | ;; EXPAND-MACRO-1 21 | 22 | (defkernel-macro foo (x) 23 | `(bar ,x)) 24 | 25 | (defkernel-macro bar (x) 26 | x) 27 | 28 | (subtest "expand-macro-1" 29 | 30 | (is-values (expand-macro-1 '(foo 1)) 31 | '((bar 1) t) 32 | "Base case - macro expanded.") 33 | 34 | (is-values (expand-macro-1 1) 35 | '(1 nil) 36 | "Base case - macro not expanded.")) 37 | 38 | 39 | ;; 40 | ;; EXPAND-MACRO 41 | 42 | (subtest "expand-macro" 43 | 44 | (is-values (expand-macro '(foo 1)) 45 | '(1 t) 46 | "Base case - macro expanded.") 47 | 48 | (is-values (expand-macro 1) 49 | '(1 nil) 50 | "Base case - macro not expanded.")) 51 | 52 | 53 | ;; 54 | ;; PROGN 55 | 56 | (subtest "progn" 57 | 58 | (is (replace-gensym 59 | (expand-macro '(progn 1 2))) 60 | '(let ((_ 1)) 61 | (progn 2)) 62 | "Base case - two forms.") 63 | 64 | (is (replace-gensym 65 | (expand-macro '(progn 1))) 66 | '1 67 | "Base case - a form.") 68 | 69 | (is-error (expand-macro '(progn)) 70 | simple-error 71 | "Invalid form.")) 72 | 73 | 74 | ;; 75 | ;; LET* 76 | 77 | (subtest "let*" 78 | 79 | (is (expand-macro-1 '(let* ((x 1) 80 | (y 1)) 81 | (+ x y))) 82 | '(let ((x 1)) 83 | (let* ((y 1)) 84 | (+ x y))) 85 | "Base case.") 86 | 87 | (is (expand-macro-1 '(let* () 88 | (+ x y))) 89 | '(progn (+ x y)) 90 | "Base case - no bindings.") 91 | 92 | (is-error (expand-macro '(let* ())) 93 | simple-error 94 | "Invalid form.")) 95 | 96 | 97 | (finalize) 98 | -------------------------------------------------------------------------------- /t/avm.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test 8 | (:use :cl 9 | :avm 10 | :prove)) 11 | (in-package :avm-test) 12 | 13 | ;; NOTE: To run this test file, execute `(asdf:test-system :avm)' in your Lisp. 14 | 15 | (plan nil) 16 | 17 | ;; blah blah blah. 18 | 19 | (finalize) 20 | -------------------------------------------------------------------------------- /t/lang/compiler/cuda/compile.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test.lang.compiler.cuda.compile 8 | (:use :cl 9 | :prove 10 | :avm 11 | :avm.lang.typenv 12 | :avm.lang.appenv 13 | :avm.lang.funenv 14 | )) 15 | (in-package :avm-test.lang.compiler.cuda.compile) 16 | 17 | 18 | (plan nil) 19 | 20 | (defmacro with-env ((aenv fenv) &body body) 21 | `(let ((,aenv (empty-appenv)) 22 | (,fenv (empty-funenv))) 23 | ,@body)) 24 | 25 | 26 | ;; 27 | ;; COMPILE-LITERAL 28 | 29 | (eval-when (:compile-toplevel :load-toplevel :execute) 30 | (setf (fdefinition 'compile-literal) 31 | #'avm.lang.compiler.cuda.compile::compile-literal)) 32 | 33 | (subtest "compile-literal" 34 | 35 | (with-env (aenv fenv) 36 | (is-values (compile-literal 1 :tail aenv fenv nil) 37 | '((return 1) nil) 38 | "Base case - int literal, tail.")) 39 | 40 | (with-env (aenv fenv) 41 | (is-values (compile-literal 1 '(:non-tail x) aenv fenv nil) 42 | '((set x 1) nil) 43 | "Base case - int literal, non-tail.")) 44 | 45 | (with-env (aenv fenv) 46 | (is-values (compile-literal 1.0 :tail aenv fenv nil) 47 | '((return 1.0) nil) 48 | "Base case - float literal, tail.")) 49 | 50 | (with-env (aenv fenv) 51 | (is-values (compile-literal 1.0 '(:non-tail x) aenv fenv nil) 52 | '((set x 1.0) nil) 53 | "Base case - float literal, non-tail.")) 54 | 55 | (with-env (aenv fenv) 56 | (is-values (compile-literal 1.0d0 :tail aenv fenv nil) 57 | '((return 1.0d0) nil) 58 | "Base case - double literal, tail.")) 59 | 60 | (with-env (aenv fenv) 61 | (is-values (compile-literal 1.0d0 '(:non-tail x) aenv fenv nil) 62 | '((set x 1.0d0) nil) 63 | "Base case - double literal, non-tail.")) 64 | 65 | (with-env (aenv fenv) 66 | (is-error (compile-literal 1 :foo aenv fenv nil) 67 | simple-error 68 | "Invalid destination."))) 69 | 70 | 71 | ;; 72 | ;; COMPILE-REFERENCE 73 | 74 | (eval-when (:compile-toplevel :load-toplevel :execute) 75 | (setf (fdefinition 'compile-reference) 76 | #'avm.lang.compiler.cuda.compile::compile-reference)) 77 | 78 | (subtest "compile-reference" 79 | 80 | (with-env (aenv fenv) 81 | (is-values (compile-reference 'x :tail aenv fenv nil) 82 | '((return x) nil) 83 | "Base case - tail.")) 84 | 85 | (with-env (aenv fenv) 86 | (is-values (compile-reference 'x '(:non-tail y) aenv fenv nil) 87 | '((set y x) nil) 88 | "Base case - non-tail.")) 89 | 90 | (with-env (aenv fenv) 91 | (is-error (compile-reference 'x :foo aenv fenv nil) 92 | simple-error 93 | "Invalid destination."))) 94 | 95 | 96 | ;; 97 | ;; COMPILE-LET 98 | 99 | (eval-when (:compile-toplevel :load-toplevel :execute) 100 | (setf (fdefinition 'compile-let) 101 | #'avm.lang.compiler.cuda.compile::compile-let)) 102 | 103 | (subtest "compile-let" 104 | 105 | (with-env (aenv fenv) 106 | (let ((form '(let (#1=(x 1)) x)) 107 | (aenv1 (extend-appenv '#1# 'int aenv))) 108 | (is-values (compile-let form :tail aenv1 fenv nil) 109 | '((let ((x 0)) (set x 1) (return x)) nil) 110 | "Base case - int value, tail."))) 111 | 112 | (with-env (aenv fenv) 113 | (let ((form '(let (#2=(x 1)) x)) 114 | (aenv1 (extend-appenv '#2# 'int aenv))) 115 | (is-values (compile-let form '(:non-tail y) aenv1 fenv nil) 116 | '((let ((x 0)) (set x 1) (set y x)) nil) 117 | "Base case - int value, non-tail."))) 118 | 119 | (with-env (aenv fenv) 120 | (let ((form '(let (#3=(x 1.0)) x)) 121 | (aenv1 (extend-appenv '#3# 'float aenv))) 122 | (is-values (compile-let form :tail aenv1 fenv nil) 123 | '((let ((x 0.0)) (set x 1.0) (return x)) nil) 124 | "Base case - float value, tail."))) 125 | 126 | (with-env (aenv fenv) 127 | (let ((form '(let (#4=(x 1.0)) x)) 128 | (aenv1 (extend-appenv '#4# 'float aenv))) 129 | (is-values (compile-let form '(:non-tail y) aenv1 fenv nil) 130 | '((let ((x 0.0)) (set x 1.0) (set y x)) nil) 131 | "Base case - float value, non-tail."))) 132 | 133 | (with-env (aenv fenv) 134 | (let ((form '(let (#5=(x (let (#6=(y 1)) 135 | y))) 136 | x)) 137 | (aenv1 (extend-appenv '#5# 'int 138 | (extend-appenv '#6# 'int 139 | aenv)))) 140 | (is-values (compile-let form :tail aenv1 fenv nil) 141 | '((let ((x 0)) 142 | (let ((y 0)) 143 | (set y 1) 144 | (set x y)) 145 | (return x)) 146 | nil) 147 | "Base case - nested LET forms."))) 148 | 149 | (with-env (aenv fenv) 150 | (let ((form '(let (#7=(x (if b 1 0))) 151 | x)) 152 | (aenv1 (extend-appenv '#7# 'int aenv))) 153 | (is-values (compile-let form :tail aenv1 fenv nil) 154 | '((let ((x 0)) 155 | (if b 156 | (set x 1) 157 | (set x 0)) 158 | (return x)) 159 | nil) 160 | "Base case - with IF form in binding.")))) 161 | 162 | 163 | (finalize) 164 | -------------------------------------------------------------------------------- /t/lang/compiler/cuda/k-normal.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test.lang.compiler.cuda.k-normal 8 | (:use :cl 9 | :prove 10 | :avm 11 | :avm.lang.compiler.cuda.k-normal 12 | )) 13 | (in-package :avm-test.lang.compiler.cuda.k-normal) 14 | 15 | 16 | (plan nil) 17 | 18 | (subtest "SETF" 19 | 20 | (is (k-normal '(setf x 1)) 21 | '(setf x 1)) 22 | 23 | (is (k-normal '(setf (int2-x x) 1)) 24 | '(setf (int2-x x) 1)) 25 | 26 | (is (k-normal '(setf (aref x 0) 1)) 27 | '(setf (aref x 0) 1)) 28 | 29 | (is (k-normal '(setf (int2-x (aref x 0)) 1)) 30 | '(setf (int2-x (aref x 0)) 1)) 31 | 32 | (let ((*gentmp-counter* 0)) 33 | (is (k-normal '(setf (aref x (+ i 1)) 1)) 34 | '(let ((t0 (+ i 1))) 35 | (setf (aref x t0) 1)))) 36 | 37 | (let ((*gentmp-counter* 0)) 38 | (is (k-normal '(setf (int2-x (aref x (+ i 1))) 1)) 39 | '(let ((t0 (+ i 1))) 40 | (setf (int2-x (aref x t0)) 1)))) 41 | 42 | (is (k-normal '(setf x y)) 43 | '(setf x y)) 44 | 45 | (let ((*gentmp-counter* 0)) 46 | (is (k-normal '(setf x (+ i 1))) 47 | '(let ((t0 (+ i 1))) 48 | (setf x t0)))) 49 | ) 50 | 51 | 52 | (finalize) 53 | -------------------------------------------------------------------------------- /t/lang/compiler/lisp/compile.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test.lang.compiler.lisp.compile 8 | (:use :cl 9 | :prove 10 | :avm 11 | :avm.lang.data 12 | :avm.lang.typenv 13 | :avm.lang.appenv 14 | :avm.lang.funenv 15 | :avm.lang.compiler.lisp.varenv 16 | :avm.lang.compiler.lisp.compile)) 17 | (in-package :avm-test.lang.compiler.lisp.compile) 18 | 19 | 20 | (plan nil) 21 | 22 | 23 | (defmacro with-env ((aenv fenv venv) &body body) 24 | `(let ((,aenv (empty-appenv)) 25 | (,fenv (empty-funenv)) 26 | (,venv (empty-varenv)) 27 | (*genvar-counter* 0) 28 | (*genname-counter* 0)) 29 | ,@body)) 30 | 31 | 32 | ;; 33 | ;; COMPILE-FUNCTION 34 | 35 | (subtest "compile-function" 36 | 37 | (with-env (aenv fenv venv) 38 | (let ((aenv1 (extend-appenv '#1=(+ x y) 39 | '((:vector int 3) (:vector int 3) 40 | (:vector int 3)) 41 | aenv))) 42 | (is-values (compile-function 'foo 43 | '((:vector int 3) (:vector int 3) int) 44 | '(x y) 45 | '#1# ; (+ x y) 46 | venv aenv1 fenv) 47 | '(foo0 (x0 x1 x2 y3 y4 y5) 48 | ((declare (optimize (speed 3) (safety 0))) 49 | (declare (ignorable x0 x1 x2 y3 y4 y5)) 50 | (declare (type fixnum x0 x1 x2)) 51 | (declare (type fixnum y3 y4 y5)) 52 | (the (values fixnum fixnum fixnum) 53 | (avm.lang.data:int3-add* 54 | (avm.lang.data:int3-values* x0 x1 x2) 55 | (avm.lang.data:int3-values* y3 y4 y5))))) 56 | "Base case - vector type arguments.")))) 57 | 58 | 59 | ;; 60 | ;; COMPILE-SETF 61 | 62 | (eval-when (:compile-toplevel :load-toplevel :execute) 63 | (setf (fdefinition 'compile-setf) 64 | #'avm.lang.compiler.lisp.compile::compile-setf)) 65 | 66 | (subtest "compile-setf" 67 | 68 | (with-env (aenv fenv venv) 69 | (let ((venv1 (extend-varenv 'x 'int venv))) 70 | (is (compile-setf '(setf x 1) venv1 aenv fenv) 71 | '(setf x0 1) 72 | "Base case - reference place of int type."))) 73 | 74 | (with-env (aenv fenv venv) 75 | (let ((form '(setf x #1=(int2 1 1))) 76 | (venv1 (extend-varenv 'x '(:vector int 2) venv)) 77 | (aenv1 (extend-appenv '#1# '(int int (:vector int 2)) aenv))) 78 | (is (compile-setf form venv1 aenv1 fenv) 79 | '(setf (int2-values* x0 x1) 80 | (the (values fixnum fixnum) (int2-values* 1 1))) 81 | "Base case - reference place of int2 type."))) 82 | 83 | (with-env (aenv fenv venv) 84 | (let ((form '(setf #2=(int2-x x) 1)) 85 | (venv1 (extend-varenv 'x '(:vector int 2) venv)) 86 | (aenv1 (extend-appenv '#2# '((:vector int 2) int) aenv))) 87 | (is (compile-setf form venv1 aenv1 fenv) 88 | '(setf (int2-x* (int2-values* x0 x1)) 1) 89 | "Base case - vector place of int2 type."))) 90 | 91 | (with-env (aenv fenv venv) 92 | (let ((form '(setf #3=(aref x 0) 1)) 93 | (venv1 (extend-varenv 'x '(:array int) venv)) 94 | (aenv1 (extend-appenv '#3# '((:array int) int int) aenv))) 95 | (is (compile-setf form venv1 aenv1 fenv) 96 | '(setf (aref x0 0) 1) 97 | "Base case - array place of int type."))) 98 | 99 | (with-env (aenv fenv venv) 100 | (let ((form '(setf #4=(aref x 0) #5=(int2 1 1))) 101 | (venv1 (extend-varenv 'x '(:array (:vector int 2)) venv)) 102 | (aenv1 (extend-appenv '#4# 103 | '((:array (:vector int 2)) int (:vector int 2)) 104 | (extend-appenv '#5# '(int int (:vector int 2)) 105 | aenv)))) 106 | (is (compile-setf form venv1 aenv1 fenv) 107 | '(setf (int2-aref* x0 0) 108 | (the (values fixnum fixnum) (int2-values* 1 1))) 109 | "Base case - array type of int2 type.")))) 110 | 111 | 112 | ;; 113 | ;; COMPILE-LET 114 | 115 | (eval-when (:compile-toplevel :load-toplevel :execute) 116 | (setf (fdefinition 'compile-let) 117 | #'avm.lang.compiler.lisp.compile::compile-let)) 118 | 119 | (subtest "compile-let" 120 | 121 | (with-env (aenv fenv venv) 122 | (let ((form '(let (#1=(x 1)) x)) 123 | (aenv1 (extend-appenv '#1# 'int aenv))) 124 | (is (compile-let form venv aenv1 fenv) 125 | '(let ((x0 1)) 126 | (declare (ignorable x0)) 127 | (declare (type fixnum x0)) 128 | x0) 129 | "Base case - scalar type."))) 130 | 131 | (with-env (aenv fenv venv) 132 | (let ((form '(let (#2=(x #3=(int2 1 1))) x)) 133 | (aenv1 (extend-appenv '#2# '(:vector int 2) 134 | (extend-appenv '#3# '(int int (:vector int 2)) 135 | aenv)))) 136 | (is (compile-let form venv aenv1 fenv) 137 | '(multiple-value-bind (x0 x1) 138 | (the (values fixnum fixnum) (avm.lang.data::int2-values* 1 1)) 139 | (declare (ignorable x0 x1)) 140 | (declare (type fixnum x0 x1)) 141 | (avm.lang.data::int2-values* x0 x1)) 142 | "Base case - vector type."))) 143 | 144 | (with-env (aenv fenv venv) 145 | (let ((form '(let (#4=(x as)) x)) 146 | (venv1 (extend-varenv 'as '(:array int) venv)) 147 | (aenv1 (extend-appenv '#4# '(:array int) aenv))) 148 | (is (compile-let form venv1 aenv1 fenv) 149 | '(let ((x1 as0)) 150 | (declare (ignorable x1)) 151 | (declare (type int-array x1)) 152 | x1) 153 | "Base case - array type."))) 154 | 155 | (with-env (aenv fenv venv) 156 | (let ((form '(let (#5=(x 1) 157 | #6=(y #7=(int2 1 1))) 158 | x)) 159 | (aenv1 (extend-appenv '#5# 'int 160 | (extend-appenv '#6# '(:vector int 2) 161 | (extend-appenv '#7# '(int int (:vector int 2)) 162 | aenv))))) 163 | (is (compile-let form venv aenv1 fenv) 164 | '(let ((x0 1)) 165 | (declare (ignorable x0)) 166 | (declare (type fixnum x0)) 167 | (multiple-value-bind (y1 y2) 168 | (the (values fixnum fixnum) (avm.lang.data::int2-values* 1 1)) 169 | (declare (ignorable y1 y2)) 170 | (declare (type fixnum y1 y2)) 171 | x0)) 172 | "Base case - multiple bindings.")))) 173 | 174 | 175 | ;; 176 | ;; COMPILE-FLET 177 | 178 | (eval-when (:compile-toplevel :load-toplevel :execute) 179 | (setf (fdefinition 'compile-flet) 180 | #'avm.lang.compiler.lisp.compile::compile-flet)) 181 | 182 | (subtest "compile-flet" 183 | 184 | (with-env (aenv fenv venv) 185 | (let ((form '(flet (#1=(aux (x) x)) 186 | #2=(aux 1))) 187 | (aenv1 (extend-appenv '#1# '(int int) 188 | (extend-appenv '#2# '(int int) aenv)))) 189 | (is (compile-flet form venv aenv1 fenv) 190 | '(flet ((aux0 (x0) 191 | (declare (optimize (speed 3) (safety 0))) 192 | (declare (ignorable x0)) 193 | (declare (type fixnum x0)) 194 | x0)) 195 | (let ((x1 1)) 196 | (declare (type fixnum x1)) 197 | (the fixnum (aux0 x1)))) 198 | "Base case."))) 199 | 200 | (with-env (aenv fenv venv) 201 | (let ((form '(flet (#3=(aux (x y) x)) 202 | #4=(aux 1 2))) 203 | (aenv1 (extend-appenv '#3# '(int int int) 204 | (extend-appenv '#4# '(int int int) aenv)))) 205 | (is (compile-flet form venv aenv1 fenv) 206 | '(flet ((aux0 (x0 y1) 207 | (declare (optimize (speed 3) (safety 0))) 208 | (declare (ignorable x0 y1)) 209 | (declare (type fixnum x0)) 210 | (declare (type fixnum y1)) 211 | x0)) 212 | (let ((x2 1)) 213 | (declare (type fixnum x2)) 214 | (let ((y3 2)) 215 | (declare (type fixnum y3)) 216 | (the fixnum (aux0 x2 y3))))) 217 | "Base case - multiple arguments.")))) 218 | 219 | 220 | ;; 221 | ;; COMPILE-LABELS 222 | 223 | (eval-when (:compile-toplevel :load-toplevel :execute) 224 | (setf (fdefinition 'compile-labels) 225 | #'avm.lang.compiler.lisp.compile::compile-labels)) 226 | 227 | (subtest "compile-labels" 228 | 229 | (with-env (aenv fenv venv) 230 | (let ((form '(labels (#1=(aux (x) (aux x))) 231 | #2=(aux 1))) 232 | (aenv1 (extend-appenv '#1# '(int int) 233 | (extend-appenv '#2# '(int int) aenv)))) 234 | (is (compile-labels form venv aenv1 fenv) 235 | '(labels ((aux0 (x0) 236 | (declare (optimize (speed 3) (safety 0))) 237 | (declare (ignorable x0)) 238 | (declare (type fixnum x0)) 239 | (let ((x1 x0)) 240 | (declare (type fixnum x1)) 241 | (the fixnum (aux0 x1))))) 242 | (let ((x2 1)) 243 | (declare (type fixnum x2)) 244 | (the fixnum (aux0 x2)))) 245 | "Base case."))) 246 | 247 | (with-env (aenv fenv venv) 248 | (let ((form '(labels (#3=(aux (x y) (aux x y))) 249 | #4=(aux 1 2))) 250 | (aenv1 (extend-appenv '#3# '(int int int) 251 | (extend-appenv '#4# '(int int int) aenv)))) 252 | (is (compile-labels form venv aenv1 fenv) 253 | '(labels ((aux0 (x0 y1) 254 | (declare (optimize (speed 3) (safety 0))) 255 | (declare (ignorable x0 y1)) 256 | (declare (type fixnum x0)) 257 | (declare (type fixnum y1)) 258 | (let ((x2 x0)) 259 | (declare (type fixnum x2)) 260 | (let ((y3 y1)) 261 | (declare (type fixnum y3)) 262 | (the fixnum (aux0 x2 y3)))))) 263 | (let ((x4 1)) 264 | (declare (type fixnum x4)) 265 | (let ((y5 2)) 266 | (declare (type fixnum y5)) 267 | (the fixnum (aux0 x4 y5))))) 268 | "Base case - multiple arguments.")))) 269 | 270 | 271 | ;; 272 | ;; COMPILE-BUILT-IN-APPLY 273 | 274 | (eval-when (:compile-toplevel :load-toplevel :execute) 275 | (setf (fdefinition 'compile-built-in-apply) 276 | #'avm.lang.compiler.lisp.compile::compile-built-in-apply)) 277 | 278 | (subtest "compile-built-in-apply" 279 | 280 | (with-env (aenv fenv venv) 281 | (let ((aenv1 (extend-appenv '#1=(+ 1 1) '(int int int) aenv))) 282 | (is (compile-built-in-apply '#1# venv aenv1 fenv) 283 | '(the fixnum (+ 1 1)) 284 | "Base case - int addition."))) 285 | 286 | (with-env (aenv fenv venv) 287 | (let ((aenv1 (extend-appenv '#2=(coerce 1) '(int double) aenv))) 288 | (is (compile-built-in-apply '#2# venv aenv1 fenv) 289 | '(the double-float (avm.lang.compiler.lisp.built-in::int->double 1)) 290 | "Base case - COERCE of int to double."))) 291 | 292 | (with-env (aenv fenv venv) 293 | (is-error (compile-built-in-apply '(+ 1 1) venv aenv fenv) 294 | simple-error 295 | "Not exist in appenv.")) 296 | 297 | (with-env (aenv fenv venv) 298 | (let ((aenv1 (extend-appenv '#3=(+ 1 1 1) '(int int int) aenv))) 299 | (is-error (compile-built-in-apply '#3# venv aenv1 fenv) 300 | simple-error 301 | "Invalid number of arguments.")))) 302 | 303 | 304 | (finalize) 305 | -------------------------------------------------------------------------------- /t/lang/convert-functions.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test.lang.convert-functions 8 | (:use :cl 9 | :prove 10 | :avm 11 | :avm.lang.convert-functions)) 12 | (in-package :avm-test.lang.convert-functions) 13 | 14 | 15 | (plan nil) 16 | 17 | 18 | ;; 19 | ;; CONVERT-LET 20 | 21 | (eval-when (:compile-toplevel :load-toplevel :execute) 22 | (setf (fdefinition 'convert-let) 23 | #'avm.lang.convert-functions::convert-let)) 24 | 25 | (subtest "convert-let" 26 | 27 | (is (convert-let '(let ((x (foo 1))) x)) 28 | '(let ((x (foo i n 1))) 29 | x) 30 | "Base case - convert binding.") 31 | 32 | (is (convert-let '(let ((x 1)) (foo x))) 33 | '(let ((x 1)) 34 | (foo i n x)) 35 | "Base case - convert body.")) 36 | 37 | 38 | ;; 39 | ;; CONVERT-FLET 40 | 41 | (eval-when (:compile-toplevel :load-toplevel :execute) 42 | (setf (fdefinition 'convert-flet) 43 | #'avm.lang.convert-functions::convert-flet)) 44 | 45 | (subtest "convert-flet" 46 | 47 | (is (convert-flet '(flet ((aux (x) (foo 1))) 48 | 1)) 49 | '(flet ((aux (i n x) (foo i n 1))) 50 | 1) 51 | "Base case - convert binding.") 52 | 53 | (is (convert-flet '(flet ((aux (x) x)) 54 | (foo 1))) 55 | '(flet ((aux (i n x) x)) 56 | (foo i n 1)) 57 | "Base case - convert body.")) 58 | 59 | 60 | ;; 61 | ;; CONVERT-LABELS 62 | 63 | (eval-when (:compile-toplevel :load-toplevel :execute) 64 | (setf (fdefinition 'convert-labels) 65 | #'avm.lang.convert-functions::convert-labels)) 66 | 67 | (subtest "convert-labels" 68 | 69 | (is (convert-labels '(labels ((aux (x) (foo 1))) 70 | 1)) 71 | '(labels ((aux (i n x) (foo i n 1))) 72 | 1) 73 | "Base case - convert binding.") 74 | 75 | (is (convert-labels '(labels ((aux (x) x)) 76 | (foo 1))) 77 | '(labels ((aux (i n x) x)) 78 | (foo i n 1)) 79 | "Base case - convert body.")) 80 | 81 | 82 | (finalize) 83 | -------------------------------------------------------------------------------- /t/lang/convert-implicit-progn.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test.lang.convert-implicit-progn 8 | (:use :cl 9 | :prove 10 | :avm 11 | :avm-test.util 12 | :avm.lang.convert-implicit-progn)) 13 | (in-package :avm-test.lang.convert-implicit-progn) 14 | 15 | 16 | (plan nil) 17 | 18 | 19 | ;; 20 | ;; CONVERT-ACCESSOR 21 | 22 | (eval-when (:compile-toplevel :load-toplevel :execute) 23 | (setf (fdefinition 'convert-accessor) 24 | #'avm.lang.convert-implicit-progn::convert-accessor)) 25 | 26 | (subtest "convert-accessor" 27 | 28 | (is (replace-gensym 29 | (convert-accessor '(int2 (let ((x 1)) 1 2) 30 | 1))) 31 | '(int2 (let ((x 1)) 32 | (let ((_ 1)) 33 | 2)) 34 | 1) 35 | "Base case.")) 36 | 37 | 38 | ;; 39 | ;; CONVERT-THE 40 | 41 | (eval-when (:compile-toplevel :load-toplevel :execute) 42 | (setf (fdefinition 'convert-the) 43 | #'avm.lang.convert-implicit-progn::convert-the)) 44 | 45 | (subtest "convert-the" 46 | 47 | (is (replace-gensym 48 | (convert-the '(the int (let ((x 1)) 1 2)))) 49 | '(the int (let ((x 1)) 50 | (let ((_ 1)) 51 | 2))) 52 | "Base case.")) 53 | 54 | 55 | ;; 56 | ;; CONVERT-IF 57 | 58 | (eval-when (:compile-toplevel :load-toplevel :execute) 59 | (setf (fdefinition 'convert-if) 60 | #'avm.lang.convert-implicit-progn::convert-if)) 61 | 62 | (subtest "convert-if" 63 | 64 | (is (replace-gensym 65 | (convert-if '(if (let ((x 1)) (= 1 1) (= 2 2)) 66 | 1 2))) 67 | '(if (let ((x 1)) 68 | (let ((_ (= 1 1))) 69 | (= 2 2))) 70 | 1 2) 71 | "Base case - test form.") 72 | 73 | (is (replace-gensym 74 | (convert-if '(if (= 1 1) 75 | (let ((x 1)) 76 | 1 2) 77 | 2))) 78 | '(if (= 1 1) 79 | (let ((x 1)) 80 | (let ((_ 1)) 81 | 2)) 82 | 2) 83 | "Base case - then form.") 84 | 85 | (is (replace-gensym 86 | (convert-if '(if (= 1 1) 87 | 1 88 | (let ((x 1)) 89 | 1 2)))) 90 | '(if (= 1 1) 91 | 1 92 | (let ((x 1)) 93 | (let ((_ 1)) 94 | 2))) 95 | "Base case - else form.")) 96 | 97 | 98 | ;; 99 | ;; CONVERT-LET 100 | 101 | (eval-when (:compile-toplevel :load-toplevel :execute) 102 | (setf (fdefinition 'convert-let) 103 | #'avm.lang.convert-implicit-progn::convert-let)) 104 | 105 | (subtest "convert-let" 106 | 107 | (is (replace-gensym 108 | (convert-let '(let ((x 1)) x x))) 109 | '(let ((x 1)) 110 | (let ((_ x)) 111 | x)) 112 | "Base case.") 113 | 114 | (is (replace-gensym 115 | (convert-let '(let ((x (let ((x 1)) 116 | x x))) 117 | x x))) 118 | '(let ((x (let ((x 1)) 119 | (let ((_ x)) 120 | x)))) 121 | (let ((_ x)) 122 | x)) 123 | "Base case - another let in binding.") 124 | 125 | (is (replace-gensym 126 | (convert-let '(let ((x 1)) 127 | (let ((x 1)) 128 | x x) 129 | x))) 130 | '(let ((x 1)) 131 | (let ((_ (let ((x 1)) 132 | (let ((_ x)) 133 | x)))) 134 | x)) 135 | "Base case - another let in body.")) 136 | 137 | 138 | ;; 139 | ;; CONVERT-FLET 140 | 141 | (eval-when (:compile-toplevel :load-toplevel :execute) 142 | (setf (fdefinition 'convert-flet) 143 | #'avm.lang.convert-implicit-progn::convert-flet)) 144 | 145 | (subtest "convert-flet" 146 | 147 | (is (replace-gensym 148 | (convert-flet '(flet ((aux () 149 | 1 2)) 150 | 1 2))) 151 | '(flet ((aux () 152 | (let ((_ 1)) 153 | 2))) 154 | (let ((_ 1)) 155 | 2)) 156 | "Base case.")) 157 | 158 | 159 | ;; 160 | ;; CONVERT-LABELS 161 | 162 | (eval-when (:compile-toplevel :load-toplevel :execute) 163 | (setf (fdefinition 'convert-labels) 164 | #'avm.lang.convert-implicit-progn::convert-labels)) 165 | 166 | (subtest "convert-labels" 167 | 168 | (is (replace-gensym 169 | (convert-labels '(labels ((aux () 170 | 1 2)) 171 | 1 2))) 172 | '(labels ((aux () 173 | (let ((_ 1)) 174 | 2))) 175 | (let ((_ 1)) 176 | 2)) 177 | "Base case.")) 178 | 179 | 180 | ;; 181 | ;; CONVERT-SETF 182 | 183 | (eval-when (:compile-toplevel :load-toplevel :execute) 184 | (setf (fdefinition 'convert-setf) 185 | #'avm.lang.convert-implicit-progn::convert-setf)) 186 | 187 | (subtest "convert-setf" 188 | 189 | (is (replace-gensym 190 | (convert-setf '(setf x (let ((x 1)) 191 | 1 2)))) 192 | '(setf x (let ((x 1)) 193 | (let ((_ 1)) 194 | 2))) 195 | "Base case.") 196 | 197 | (is (replace-gensym 198 | (convert-setf '(setf (aref x (let ((x 1)) 199 | 1 2)) 200 | 1))) 201 | '(setf (aref x (let ((x 1)) 202 | (let ((_ 1)) 203 | 2))) 204 | 1) 205 | "Base case - LET form in array place.")) 206 | 207 | 208 | ;; 209 | ;; CONVERT-APPLY 210 | 211 | (eval-when (:compile-toplevel :load-toplevel :execute) 212 | (setf (fdefinition 'convert-apply) 213 | #'avm.lang.convert-implicit-progn::convert-apply)) 214 | 215 | (subtest "convert-apply" 216 | 217 | (is (replace-gensym 218 | (convert-apply '(foo (let ((x 1)) 1 2)))) 219 | '(foo (let ((x 1)) 220 | (let ((_ 1)) 221 | 2))) 222 | "Base case.")) 223 | 224 | 225 | (finalize) 226 | -------------------------------------------------------------------------------- /t/lang/expand-macro.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test.lang.expand-macro 8 | (:use :cl 9 | :prove 10 | :avm 11 | :avm.lang.funenv 12 | :avm.lang.expand-macro) 13 | (:shadowing-import-from :avm.lang.expand-macro 14 | :expand-macro)) 15 | (in-package :avm-test.lang.expand-macro) 16 | 17 | 18 | (plan nil) 19 | 20 | (defmacro with-env ((var) &body body) 21 | `(let ((,var (extend-funenv-macro 'foo '(x) '(x) 22 | #'(lambda (args) 23 | (destructuring-bind (x) args 24 | x)) 25 | (empty-funenv)))) 26 | ,@body)) 27 | 28 | 29 | ;; 30 | ;; MACRO-P 31 | 32 | (eval-when (:compile-toplevel :load-toplevel :execute) 33 | (setf (fdefinition 'macro-p) 34 | #'avm.lang.expand-macro::macro-p)) 35 | 36 | (subtest "macro-p" 37 | 38 | (with-env (fenv) 39 | (is (macro-p 1 fenv) 40 | nil 41 | "Base case - not list.")) 42 | 43 | (with-env (fenv) 44 | (is (macro-p '(foo 1) fenv) 45 | t 46 | "Base case - macro.")) 47 | 48 | (with-env (fenv) 49 | (is (macro-p '(bar 1) fenv) 50 | nil 51 | "Base case - not macro.")) 52 | 53 | (with-env (fenv) 54 | (is (macro-p '(1) fenv) 55 | nil 56 | "Base case - not macro.")) 57 | 58 | (is-error (macro-p '(foo 1) :foo) 59 | type-error 60 | "Invalid funenv.")) 61 | 62 | 63 | ;; 64 | ;; EXPAND-MACRO-MACRO 65 | 66 | (eval-when (:compile-toplevel :load-toplevel :execute) 67 | (setf (fdefinition 'expand-macro-macro) 68 | #'avm.lang.expand-macro::expand-macro-macro)) 69 | 70 | (subtest "expand-macro-macro" 71 | 72 | (with-env (fenv) 73 | (is (expand-macro-macro '(foo 1) fenv) 74 | 1 75 | "Base case.")) 76 | 77 | (with-env (fenv) 78 | (is (expand-macro-macro '(foo (foo 1)) fenv) 79 | 1 80 | "Base case - nested macro."))) 81 | 82 | 83 | ;; 84 | ;; EXPAND-MACRO-LITERAL 85 | 86 | (eval-when (:compile-toplevel :load-toplevel :execute) 87 | (setf (fdefinition 'expand-macro-literal) 88 | #'avm.lang.expand-macro::expand-macro-literal)) 89 | 90 | (subtest "expand-macro-literal" 91 | 92 | (with-env (fenv) 93 | (is (expand-macro-literal 1 fenv) 94 | 1 95 | "Base case."))) 96 | 97 | 98 | ;; 99 | ;; EXPAND-MACRO-REFERENCE 100 | 101 | (eval-when (:compile-toplevel :load-toplevel :execute) 102 | (setf (fdefinition 'expand-macro-reference) 103 | #'avm.lang.expand-macro::expand-macro-reference)) 104 | 105 | (subtest "expand-macro-reference" 106 | 107 | (with-env (fenv) 108 | (is (expand-macro-reference 'x fenv) 109 | 'x 110 | "Base case."))) 111 | 112 | 113 | ;; 114 | ;; EXPAND-MACRO-ACCESSOR 115 | 116 | (eval-when (:compile-toplevel :load-toplevel :execute) 117 | (setf (fdefinition 'expand-macro-accessor) 118 | #'avm.lang.expand-macro::expand-macro-accessor)) 119 | 120 | (subtest "expand-macro-accessor" 121 | 122 | (with-env (fenv) 123 | (is (expand-macro-accessor '(int2-x (foo x)) fenv) 124 | '(int2-x x) 125 | "Base case."))) 126 | 127 | 128 | ;; 129 | ;; EXPAND-MACRO-THE 130 | 131 | (eval-when (:compile-toplevel :load-toplevel :execute) 132 | (setf (fdefinition 'expand-macro-the) 133 | #'avm.lang.expand-macro::expand-macro-the)) 134 | 135 | (subtest "expand-macro-the" 136 | 137 | (with-env (fenv) 138 | (is (expand-macro-the '(the int (foo 1)) fenv) 139 | '(the int 1) 140 | "Base case."))) 141 | 142 | 143 | ;; 144 | ;; EXPAND-MACRO-IF 145 | 146 | (eval-when (:compile-toplevel :load-toplevel :execute) 147 | (setf (fdefinition 'expand-macro-if) 148 | #'avm.lang.expand-macro::expand-macro-if)) 149 | 150 | (subtest "expand-macro-if" 151 | 152 | (with-env (fenv) 153 | (is (expand-macro-if '(if (foo (= 1 1)) 1 2) fenv) 154 | '(if (= 1 1) 1 2) 155 | "Base case - test form.")) 156 | 157 | (with-env (fenv) 158 | (is (expand-macro-if '(if (= 1 1) (foo 1) 2) fenv) 159 | '(if (= 1 1) 1 2) 160 | "Base case - then form.")) 161 | 162 | (with-env (fenv) 163 | (is (expand-macro-if '(if (= 1 1) 1 (foo 2)) fenv) 164 | '(if (= 1 1) 1 2) 165 | "Base case - else form."))) 166 | 167 | 168 | ;; 169 | ;; EXPAND-MACRO-LET 170 | 171 | (eval-when (:compile-toplevel :load-toplevel :execute) 172 | (setf (fdefinition 'expand-macro-let) 173 | #'avm.lang.expand-macro::expand-macro-let)) 174 | 175 | (subtest "expand-macro-let" 176 | 177 | (with-env (fenv) 178 | (is (expand-macro-let '(let ((x (foo 1))) x) fenv) 179 | '(let ((x 1)) x) 180 | "Base case - macro in binding.")) 181 | 182 | (with-env (fenv) 183 | (is (expand-macro-let '(let ((x 1)) (foo x) (foo 1)) fenv) 184 | '(let ((x 1)) x 1) 185 | "Base case - macro in body."))) 186 | 187 | 188 | ;; 189 | ;; EXPAND-MACRO-FLET 190 | 191 | (eval-when (:compile-toplevel :load-toplevel :execute) 192 | (setf (fdefinition 'expand-macro-flet) 193 | #'avm.lang.expand-macro::expand-macro-flet)) 194 | 195 | (subtest "expand-macro-flet" 196 | 197 | (with-env (fenv) 198 | (is (expand-macro-flet '(flet ((aux () (foo 1) (foo 2))) 199 | (aux)) 200 | fenv) 201 | '(flet ((aux () 1 2)) 202 | (aux)) 203 | "Base case - macro in binding.")) 204 | 205 | (with-env (fenv) 206 | (is (expand-macro-flet '(flet ((aux () 1)) 207 | (foo 1) 208 | (foo (aux 2))) 209 | fenv) 210 | '(flet ((aux () 1)) 211 | 1 (aux 2)) 212 | "Base case - macro in body."))) 213 | 214 | 215 | ;; 216 | ;; EXPAND-MACRO-LABELS 217 | 218 | (eval-when (:compile-toplevel :load-toplevel :execute) 219 | (setf (fdefinition 'expand-macro-labels) 220 | #'avm.lang.expand-macro::expand-macro-labels)) 221 | 222 | (subtest "expand-macro-flet" 223 | 224 | (with-env (fenv) 225 | (is (expand-macro-labels '(labels ((aux () (foo 1) (foo 2))) 226 | (aux)) 227 | fenv) 228 | '(labels ((aux () 1 2)) 229 | (aux)) 230 | "Base case - macro in binding.")) 231 | 232 | (with-env (fenv) 233 | (is (expand-macro-labels '(labels ((aux () 1)) 234 | (foo 1) 235 | (foo (aux 2))) 236 | fenv) 237 | '(labels ((aux () 1)) 238 | 1 (aux 2)) 239 | "Base case - macro in body."))) 240 | 241 | 242 | ;; 243 | ;; EXPAND-MACRO-SETF 244 | 245 | (eval-when (:compile-toplevel :load-toplevel :execute) 246 | (setf (fdefinition 'expand-macro-setf) 247 | #'avm.lang.expand-macro::expand-macro-setf)) 248 | 249 | (subtest "expand-macro-setf" 250 | 251 | (with-env (fenv) 252 | (is (expand-macro-setf '(setf (aref x (foo 0)) 1) fenv) 253 | '(setf (aref x 0) 1) 254 | "Base case - macro in array place.")) 255 | 256 | (with-env (fenv) 257 | (is (expand-macro-setf '(setf (aref x 0) (foo 1)) fenv) 258 | '(setf (aref x 0) 1) 259 | "Base case - macro in new value."))) 260 | 261 | 262 | ;; 263 | ;; EXPAND-MACRO-APPLY 264 | 265 | (eval-when (:compile-toplevel :load-toplevel :execute) 266 | (setf (fdefinition 'expand-macro-apply) 267 | #'avm.lang.expand-macro::expand-macro-apply)) 268 | 269 | (subtest "expand-macro-apply" 270 | 271 | (with-env (fenv) 272 | (is (expand-macro-apply '(bar (foo 1) (foo 2)) fenv) 273 | '(bar 1 2) 274 | "Base case."))) 275 | 276 | 277 | (finalize) 278 | 279 | -------------------------------------------------------------------------------- /t/lang/free-variable.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test.lang.free-variable 8 | (:use :cl 9 | :prove 10 | :avm.lang.free-variable)) 11 | (in-package :avm-test.lang.free-variable) 12 | 13 | 14 | (plan nil) 15 | 16 | 17 | ;; 18 | ;; CHECK-FREE-VARIABLE-LET 19 | 20 | (eval-when (:compile-toplevel :load-toplevel :execute) 21 | (setf (fdefinition 'check-free-variable-let) 22 | #'avm.lang.free-variable::check-free-variable-let)) 23 | 24 | (subtest "check-free-variable-let" 25 | 26 | (is (check-free-variable-let '(let ((x 1)) x) nil nil) 27 | '(x) 28 | "Base case.") 29 | 30 | (is-error (check-free-variable-let '(let ((x y)) x) nil nil) 31 | simple-error 32 | "Base case - free variable in binding.") 33 | 34 | (is-error (check-free-variable-let '(let ((x 1)) y) nil nil) 35 | simple-error 36 | "Base case - free variable in body.")) 37 | 38 | 39 | ;; 40 | ;; CHECK-FREE-VARIABLE-FLET 41 | 42 | (eval-when (:compile-toplevel :load-toplevel :execute) 43 | (setf (fdefinition 'check-free-variable-flet) 44 | #'avm.lang.free-variable::check-free-variable-flet)) 45 | 46 | (subtest "check-free-variable-flet" 47 | 48 | (is (check-free-variable-flet '(flet ((foo () 1)) 1) nil nil) 49 | nil 50 | "Base case.") 51 | 52 | (is-error (check-free-variable-flet '(flet ((foo () x)) 1) nil nil) 53 | simple-error 54 | "Base case - free variable in binding.") 55 | 56 | (is-error (check-free-variable-flet '(flet ((foo () 1)) x) nil nil) 57 | simple-error 58 | "Base case - free variable in body.")) 59 | 60 | 61 | ;; 62 | ;; CHECK-FREE-VARIABLE-LABELS 63 | 64 | (eval-when (:compile-toplevel :load-toplevel :execute) 65 | (setf (fdefinition 'check-free-variable-labels) 66 | #'avm.lang.free-variable::check-free-variable-labels)) 67 | 68 | (subtest "check-free-variable-labels" 69 | 70 | (is (check-free-variable-labels '(labels ((foo () 1)) 1) nil nil) 71 | nil 72 | "Base case.") 73 | 74 | (is-error (check-free-variable-labels '(labels ((foo (x) x y)) 1) nil nil) 75 | simple-error 76 | "Base case - free variable in binding forms.") 77 | 78 | (is-error (check-free-variable-labels '(labels ((foo () 1)) x) nil nil) 79 | simple-error 80 | "Base case - free variable in body.")) 81 | 82 | 83 | (finalize) 84 | -------------------------------------------------------------------------------- /t/util.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of avm project. 3 | Copyright (c) 2016 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage avm-test.util 8 | (:use :cl) 9 | (:export :replace-gensym 10 | :_)) 11 | (in-package :avm-test.util) 12 | 13 | 14 | (defun replace-gensym (form) 15 | (if (atom form) 16 | (if (and (symbolp form) 17 | (null (symbol-package form))) 18 | '_ 19 | form) 20 | (mapcar #'replace-gensym form))) 21 | --------------------------------------------------------------------------------