├── compile-program.png ├── .gitignore ├── src ├── oclcl.lisp ├── lang │ ├── compiler │ │ ├── compile-type.lisp │ │ ├── compile-data.lisp │ │ ├── type-of-expression.lisp │ │ ├── compile-program.lisp │ │ ├── compile-expression.lisp │ │ └── compile-statement.lisp │ ├── util.lisp │ ├── lang.lisp │ ├── data.lisp │ ├── type.lisp │ ├── environment.lisp │ └── syntax.lisp └── api │ ├── api.lisp │ ├── epilogue.lisp │ └── defkernel.lisp ├── circle.yml ├── .travis.yml ├── tests ├── lang │ ├── compiler │ │ ├── compile-type.lisp │ │ ├── compile-data.lisp │ │ ├── compile-program.lisp │ │ ├── type-of-expression.lisp │ │ ├── compile-expression.lisp │ │ └── compile-statement.lisp │ ├── data.lisp │ ├── util.lisp │ ├── type.lisp │ ├── built-in.lisp │ ├── syntax.lisp │ └── environment.lisp ├── utils.lisp └── api │ └── defkernel.lisp ├── roswell └── run-oclcl-examples.ros ├── oclcl-examples.asd ├── oclcl-tests.asd ├── examples ├── README.markdown ├── shared-memory.lisp ├── vector-add.lisp ├── vector-add-oclapi.lisp ├── diffuse0.lisp ├── diffuse0-oclapi.lisp ├── diffuse1.lisp └── diffuse1-oclapi.lisp ├── oclcl.asd ├── COMPILER-PATH-DESCRIBED.md └── README.markdown /compile-program.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gos-k/oclcl/HEAD/compile-program.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | work 8 | src/drvapi_error_string.h 9 | *.pgm 10 | *~ -------------------------------------------------------------------------------- /src/oclcl.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl 9 | (:use :cl :cl-reexport)) 10 | (in-package :oclcl) 11 | 12 | (reexport-from :oclcl.lang) 13 | (reexport-from :oclcl.api) 14 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | machine: 2 | environment: 3 | PATH: $HOME/.local/bin:$HOME/.roswell/bin:$PATH 4 | ROSWELL_INSTALL_DIR: $HOME/.local 5 | 6 | dependencies: 7 | pre: 8 | - | 9 | if [ ! -e "$ROSWELL_INSTALL_DIR/bin/ros" ]; then 10 | curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh 11 | fi 12 | - ros install prove 13 | - ros -s oclcl -s oclcl-test 14 | 15 | cache_directories: 16 | - ~/.local 17 | - ~/.roswell/ 18 | - ~/.cache/common-lisp 19 | 20 | test: 21 | override: 22 | - run-prove oclcl-test.asd 23 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | 3 | env: 4 | global: 5 | - PATH=$HOME/.local/bin:$HOME/.roswell/bin:$PATH 6 | - ROSWELL_INSTALL_DIR=$HOME/.local 7 | 8 | install: 9 | - | 10 | if [ ! -e "$ROSWELL_INSTALL_DIR/bin/ros" ]; then 11 | curl -L https://raw.githubusercontent.com/roswell/roswell/release/scripts/install-for-ci.sh | sh 12 | fi 13 | - ros install prove 14 | - ros -s oclcl -s oclcl-test 15 | 16 | 17 | cache: 18 | directories: 19 | - $HOME/.local 20 | - $HOME/.roswell 21 | - $HOME/.cache/common-lisp 22 | 23 | script: 24 | - run-prove oclcl-test.asd 25 | -------------------------------------------------------------------------------- /src/lang/compiler/compile-type.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.lang.compiler.compile-type 9 | (:use :cl 10 | :oclcl.lang.type) 11 | (:export :compile-type)) 12 | (in-package :oclcl.lang.compiler.compile-type) 13 | 14 | 15 | ;;; 16 | ;;; Type 17 | ;;; 18 | 19 | (defun compile-type (type) 20 | (unless (oclcl-type-p type) 21 | (error "The value ~S is an invalid oclcl type." type)) 22 | (opencl-type type)) 23 | -------------------------------------------------------------------------------- /tests/lang/compiler/compile-type.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.tests.lang.compiler.compile-type 9 | (:use :cl :rove 10 | :oclcl.tests.utils 11 | :oclcl.lang.type 12 | :oclcl.lang.compiler.compile-type)) 13 | (in-package :oclcl.tests.lang.compiler.compile-type) 14 | 15 | ;;; 16 | ;;; test COMPILE-TYPE function 17 | ;;; 18 | 19 | (deftest compile-type 20 | (is (compile-type 'int) "int" 21 | "basic case 1")) 22 | 23 | 24 | -------------------------------------------------------------------------------- /src/api/api.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.api 9 | (:use :cl :cl-reexport) 10 | (:documentation " 11 | Exports the symbols for manipulating OpenCL programs. 12 | APIs for writing those programs (e.g. float4, etc...) are not exported from this package.")) 13 | (in-package :oclcl.api) 14 | 15 | (reexport-from :oclcl.api.defkernel) 16 | (reexport-from :oclcl.api.epilogue) 17 | (reexport-from :oclcl.lang.compiler.compile-program 18 | :include '(:compile-program)) 19 | (reexport-from :oclcl.lang.program) 20 | -------------------------------------------------------------------------------- /tests/lang/data.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.tests.lang.data 9 | (:use :cl :rove 10 | :oclcl.tests.utils 11 | :oclcl.lang.data 12 | :oclcl.lang.type)) 13 | (in-package :oclcl.tests.lang.data) 14 | 15 | ;;; 16 | ;;; test Float3 17 | ;;; 18 | 19 | (deftest float3 20 | (let ((cffi-type (cffi-type 'float3))) 21 | (cffi:with-foreign-object (x cffi-type) 22 | (setf (cffi:mem-ref x cffi-type) (make-float3 1.0f0 1.0f0 1.0f0)) 23 | (ok (float3-= (cffi:mem-ref x cffi-type) (make-float3 1.0f0 1.0f0 1.0f0)) 24 | "basic case 1")))) 25 | 26 | -------------------------------------------------------------------------------- /roswell/run-oclcl-examples.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | (progn ;;init forms 7 | (ros:ensure-asdf) 8 | #+quicklisp (ql:quickload '(:oclcl-examples :fiveam) :silent t) 9 | ) 10 | 11 | (defpackage :ros.script.run-examples.3716963759 12 | (:use :cl :fiveam)) 13 | (in-package :ros.script.run-examples.3716963759) 14 | 15 | (test test 16 | (finishes 17 | (oclcl-examples.diffuse0-oclapi:main)) 18 | (finishes 19 | (oclcl-examples.diffuse1-oclapi:main)) 20 | (finishes 21 | (oclcl-examples.sph-oclapi:main)) 22 | (finishes 23 | (oclcl-examples.vector-add-oclapi:main))) 24 | 25 | (defun main (&rest argv) 26 | (declare (ignorable argv)) 27 | (run! 'test)) 28 | 29 | ;;; vim: set ft=lisp lisp: 30 | -------------------------------------------------------------------------------- /tests/utils.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2025 gos-k (mag4.elan@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage :oclcl.tests.utils 8 | (:use :cl :rove) 9 | (:import-from #:oclcl.lang.environment 10 | #:empty-environment) 11 | (:export #:is 12 | #:is-values 13 | #:with-empty-env)) 14 | (in-package :oclcl.tests.utils) 15 | 16 | (defmacro is (lhs rhs &optional desc) 17 | `(ok (equal ,lhs ,rhs) ,desc)) 18 | 19 | (defmacro is-values (lhs rhs &optional desc) 20 | `(ok (equalp (multiple-value-list ,lhs) ,rhs) ,desc)) 21 | 22 | (defun call-with-empty-env (fun) 23 | (funcall fun (empty-environment))) 24 | 25 | (defmacro with-empty-env ((env) &body body) 26 | `(call-with-empty-env (lambda (,env) ,@body))) -------------------------------------------------------------------------------- /oclcl-examples.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl-examples-asd 9 | (:use :cl :asdf)) 10 | (in-package :oclcl-examples-asd) 11 | 12 | (defsystem oclcl-examples 13 | :author "gos-k" 14 | :license "LLGPL" 15 | :depends-on (:oclcl 16 | ;:eazy-opencl 17 | :cl-oclapi 18 | :imago) 19 | :components ((:module "examples" 20 | :components 21 | ((:file "sph-cpu") 22 | ;(:file "vector-add") 23 | ;(:file "diffuse0") 24 | ;(:file "diffuse1") 25 | (:file "vector-add-oclapi") 26 | (:file "diffuse0-oclapi") 27 | (:file "diffuse1-oclapi") 28 | (:file "sph-oclapi"))))) 29 | -------------------------------------------------------------------------------- /src/api/epilogue.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage :oclcl.api.epilogue 9 | (:use :cl 10 | :oclcl.api.defkernel 11 | :oclcl.lang.program) 12 | (:export :let* 13 | :when 14 | :unless) 15 | (:documentation 16 | "Contains the epilogue code for the system that defines the default set of 17 | kernel module and its kernel macros.")) 18 | (in-package :oclcl.api.epilogue) 19 | 20 | (define-program :oclcl) 21 | (in-program :oclcl) 22 | 23 | (defkernelmacro let* (bindings &body body) 24 | (if bindings 25 | `(let (,(car bindings)) 26 | (let* (,@(cdr bindings)) 27 | ,@body)) 28 | `(progn ,@body))) 29 | 30 | (defkernelmacro when (test &body body) 31 | `(if ,test 32 | (progn ,@body))) 33 | 34 | (defkernelmacro unless (test &body body) 35 | `(if (not ,test) 36 | (progn ,@body))) 37 | -------------------------------------------------------------------------------- /oclcl-tests.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2017-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (defsystem "oclcl-tests" 8 | :author "gos-k" 9 | :license "LLGPL" 10 | :depends-on ("oclcl" 11 | "rove" 12 | "arrow-macros") 13 | :pathname "tests" 14 | :components ((:file "utils") 15 | (:module "lang" 16 | :components 17 | ((:file "util") 18 | (:file "data") 19 | (:file "type") 20 | (:file "syntax") 21 | (:file "environment") 22 | (:file "built-in") 23 | (:file "program") 24 | (:module "compiler" 25 | :components 26 | ((:file "compile-data") 27 | (:file "compile-type") 28 | (:file "type-of-expression") 29 | (:file "compile-expression") 30 | (:file "compile-statement") 31 | (:file "compile-program"))))) 32 | (:module "api" 33 | :components 34 | ((:file "defkernel")))) 35 | :perform (test-op (op c) (symbol-call :rove '#:run c :style :dot))) 36 | -------------------------------------------------------------------------------- /examples/README.markdown: -------------------------------------------------------------------------------- 1 | # Installation 2 | 3 | ``` 4 | git clone https://github.com/cffi/cffi.git ~/.roswell/local-projects/cffi 5 | git clone https://github.com/guicho271828/eazy-opencl ~/.roswell/local-projects/eazy-opencl 6 | ros install cffi 7 | ros install cffi-grovel 8 | ros install eazy-opencl 9 | ``` 10 | 11 | # Execution 12 | 13 | ``` 14 | ros run 15 | ``` 16 | 17 | ``` 18 | (ql:quickload :oclcl) 19 | (ql:quickload :oclcl-examples) 20 | (oclcl-examples.vector-add:main) 21 | (oclcl-examples.diffuse0:main) 22 | (oclcl-examples.diffuse1:main) 23 | (oclcl-examples.vector-add-oclapi:main) 24 | (oclcl-examples.diffuse0-oclapi:main) 25 | (oclcl-examples.diffuse1-oclapi:main) 26 | (oclcl-examples.sph-oclapi:main) 27 | ``` 28 | 29 | ## SPH 30 | 31 | Output pov files. 32 | 33 | ```for i in *.pov; do povray -D0 $i; done; convert *.png output.m4v 34 | ``` 35 | (ql:quickload :oclcl-examples) 36 | (oclcl-examples.sph-oclapi:main :pov-files t) 37 | ``` 38 | 39 | Output m4v file. 40 | 41 | ``` 42 | for i in *.pov; do povray -D0 $i; done; convert *.png output.m4v 43 | ``` 44 | 45 | Show m4v file. 46 | 47 | ``` 48 | vlc output.m4v 49 | ``` 50 | 51 | 52 | # cl-cuda to oclcl 53 | 54 | thread-idx-x -> (get-local-id 0) 55 | block-idx-x -> (get-group-id 0) 56 | block-idx-y -> (get-group-id 1) 57 | (+ (* block-idx-x block-dim-x) thread-idx-x) -> (get-global-id 0) 58 | -------------------------------------------------------------------------------- /src/lang/util.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.lang.util 9 | (:use :cl) 10 | (:import-from #:serapeum 11 | #:fmt) 12 | (:export :c-identifier 13 | :c-macro-name 14 | :lines 15 | :unlines 16 | :indent)) 17 | (in-package oclcl.lang.util) 18 | 19 | 20 | (defun %c-identifier (object) 21 | (substitute-if #\_ (lambda (char) 22 | (and (not (alphanumericp char)) 23 | (not (char= #\_ char)) 24 | (not (char= #\* char)))) 25 | (string-downcase object))) 26 | 27 | (defun c-identifier (symbol &optional package-p) 28 | (let ((symbol-name (%c-identifier 29 | (symbol-name symbol)))) 30 | (if package-p 31 | (let ((package-name (%c-identifier 32 | (package-name 33 | (symbol-package symbol))))) 34 | (concatenate 'string package-name "_" symbol-name)) 35 | symbol-name))) 36 | 37 | (defun c-macro-name (keyword) 38 | (substitute #\_ #\- (symbol-name keyword))) 39 | 40 | (defun lines (str) 41 | (split-sequence:split-sequence #\LineFeed str :remove-empty-subseqs t)) 42 | 43 | (defun unlines (&rest args) 44 | (fmt "~{~A~%~}" args)) 45 | 46 | (defun indent (n str) 47 | (labels ((aux (x) 48 | (fmt "~vT~A" n x))) 49 | (apply #'unlines (mapcar #'aux (lines str))))) 50 | 51 | 52 | -------------------------------------------------------------------------------- /tests/lang/compiler/compile-data.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.tests.lang.compiler.compile-data 9 | (:use :cl :rove 10 | :oclcl.tests.utils 11 | :oclcl.lang.compiler.compile-data)) 12 | (in-package :oclcl.tests.lang.compiler.compile-data) 13 | 14 | ;;; 15 | ;;; test COMPILE-SYMBOL function 16 | ;;; 17 | 18 | (deftest compile-symbol 19 | (is (compile-symbol 'x) "x" 20 | "basic case 1") 21 | (is (compile-symbol 'vec-add-kernel) "vec_add_kernel" 22 | "basic case 2")) 23 | 24 | 25 | ;;; 26 | ;;; test COMPILE-BOOL function 27 | ;;; 28 | 29 | (deftest compile-bool 30 | (is (compile-bool t) "true" 31 | "basic case 1") 32 | (is (compile-bool nil) "false" 33 | "basic case 2")) 34 | 35 | 36 | ;;; 37 | ;;; test COMPILE-INT function 38 | ;;; 39 | 40 | (deftest compile-int 41 | (is (compile-int 1) "1" 42 | "basic case 1")) 43 | 44 | 45 | ;;; 46 | ;;; test COMPILE-FLOAT function 47 | ;;; 48 | 49 | (deftest compile-float 50 | (is (compile-float 1.0f0) "1.0f") 51 | (is (compile-float 1.23456789012345f0) "1.2345679f")) 52 | 53 | 54 | ;;; 55 | ;;; test COMPILE-DOUBLE function 56 | ;;; 57 | 58 | (deftest compile-double 59 | (is (compile-double 1.0d0) "1.0") 60 | (is (compile-double 1.23456789012345d0) "1.23456789012345")) 61 | 62 | ;;; test COMPILE-STRING function 63 | 64 | (deftest compile-string 65 | (is (compile-string "unittest compile-string") 66 | "\"unittest compile-string\"")) 67 | -------------------------------------------------------------------------------- /tests/lang/util.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.tests.lang.util 9 | (:use :cl :rove 10 | :oclcl.tests.utils 11 | :oclcl.lang.util) 12 | (:import-from #:serapeum 13 | #:fmt)) 14 | (in-package :oclcl.tests.lang.util) 15 | 16 | ;;; 17 | ;;; test C-IDENTIFIER function 18 | ;;; 19 | 20 | (deftest c-identifier 21 | (is (c-identifier 'x) "x" 22 | "basic case 1") 23 | (is (c-identifier 'vec-add-kernel) "vec_add_kernel" 24 | "basic case 2") 25 | (is (c-identifier 'vec.add.kernel) "vec_add_kernel" 26 | "basic case 3") 27 | (is (c-identifier '%vec-add-kernel) "_vec_add_kernel" 28 | "basic case 4") 29 | (is (c-identifier 'VecAdd_kernel) "vecadd_kernel" 30 | "basic case 5") 31 | (is (c-identifier 'foo t) "oclcl_tests_lang_util_foo" 32 | "basic case 6")) 33 | 34 | (deftest c-macro-name 35 | (is (c-macro-name :--alfa-bravo-charlie--) 36 | "__ALFA_BRAVO_CHARLIE__" 37 | "keyword symbol to C macro name")) 38 | 39 | ;;; 40 | ;;; test LINES function 41 | ;;; 42 | 43 | (deftest lines 44 | (is (lines (fmt "1~%2~%3~%")) '("1" "2" "3") 45 | "basic case 1") 46 | (is (lines (fmt "1~%2~%3")) '("1" "2" "3") 47 | "basic case 2")) 48 | 49 | 50 | ; 51 | ;;; test UNLINES function 52 | ;;; 53 | 54 | (deftest unlines 55 | (is (unlines "1" "2" "3") "1 56 | 2 57 | 3 58 | " "basic case 1")) 59 | 60 | 61 | ;;; 62 | ;;; test INDENT function 63 | ;;; 64 | 65 | (deftest indent 66 | (is (indent 2 (fmt "1~%2~%3~%")) " 1 67 | 2 68 | 3 69 | " "basic case 1") 70 | 71 | (is (indent 2 (fmt "1~%2~%3")) " 1 72 | 2 73 | 3 74 | " "basic case 2")) 75 | -------------------------------------------------------------------------------- /src/lang/compiler/compile-data.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.lang.compiler.compile-data 9 | (:use :cl 10 | :oclcl.lang.data 11 | :oclcl.lang.util) 12 | (:import-from #:serapeum 13 | #:fmt) 14 | (:export :compile-symbol 15 | :compile-bool 16 | :compile-int 17 | :compile-float 18 | :compile-double 19 | :compile-string)) 20 | (in-package :oclcl.lang.compiler.compile-data) 21 | 22 | 23 | ;;; 24 | ;;; Symbol 25 | ;;; 26 | 27 | (defun compile-symbol (expr) 28 | (unless (oclcl-symbol-p expr) 29 | (error "The value ~S is an invalid expression." expr)) 30 | (c-identifier expr)) 31 | 32 | 33 | ;;; 34 | ;;; Bool 35 | ;;; 36 | 37 | (defun compile-bool (expr) 38 | (unless (oclcl-bool-p expr) 39 | (error "The value ~S is an invalid expression." expr)) 40 | (if expr "true" "false")) 41 | 42 | 43 | ;;; 44 | ;;; Int 45 | ;;; 46 | 47 | (defun compile-int (expr) 48 | (unless (oclcl-int-p expr) 49 | (error "The value ~S is an invalid expression." expr)) 50 | (princ-to-string expr)) 51 | 52 | 53 | ;;; 54 | ;;; Float 55 | ;;; 56 | 57 | (defun compile-float (expr) 58 | (unless (oclcl-float-p expr) 59 | (error "The value ~S is an invalid expression." expr)) 60 | (fmt "~Ff" expr)) 61 | 62 | 63 | ;;; 64 | ;;; Double 65 | ;;; 66 | 67 | (defun compile-double (expr) 68 | (unless (oclcl-double-p expr) 69 | (error "The value ~S is an invalid expression." expr)) 70 | (fmt "~F" (float expr 0.0d0))) 71 | 72 | ;;; String 73 | 74 | (defun compile-string (expr) 75 | (unless (oclcl-string-p expr) 76 | (error "The value ~S is an invalid expression." expr)) 77 | (fmt "~S" expr)) 78 | -------------------------------------------------------------------------------- /oclcl.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2017-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | ;;; 8 | ;;; oclcl system definition 9 | ;;; 10 | 11 | (defsystem "oclcl" 12 | :version "0.1" 13 | :author "gos-k" 14 | :license "LLGPL" 15 | :depends-on ("cffi" "alexandria" "serapeum" "external-program" "osicat" 16 | "cl-pattern" "split-sequence" "cl-reexport" "cl-ppcre" 17 | "lisp-namespace") 18 | :components ((:module "src" 19 | :serial t 20 | :components 21 | ((:module "lang" 22 | :serial t 23 | :components 24 | ((:file "util") 25 | (:file "data") 26 | (:file "type") 27 | (:file "syntax") 28 | (:file "environment") 29 | (:file "built-in") 30 | (:file "program") 31 | (:file "compiler/compile-data") 32 | (:file "compiler/compile-type") 33 | (:file "compiler/type-of-expression") 34 | (:file "compiler/compile-expression") 35 | (:file "compiler/compile-statement") 36 | (:file "compiler/compile-program") 37 | (:file "lang"))) 38 | (:module "api" 39 | :serial t 40 | :components 41 | ((:file "defkernel") 42 | (:file "epilogue") 43 | (:file "api"))) 44 | (:file "oclcl")))) 45 | :description "oclcl is a library S-expression to OpenCL C." 46 | ;; :long-description #.(read-file-string (subpathname *load-pathname* "README.markdown")) 47 | :in-order-to ((test-op (test-op "oclcl-tests")))) 48 | -------------------------------------------------------------------------------- /COMPILER-PATH-DESCRIBED.md: -------------------------------------------------------------------------------- 1 | 2 | # setting up a kernel module 3 | 4 | ``` common-lisp 5 | (define-program p) 6 | ``` 7 | 8 | This sets up a program instance, which corresponds to a compilation 9 | unit given to CREATE-PROGRAM-WITH-SOURCE. In other words, one program 10 | corresponds to an OpenCL C source file. Nope, there are not files, they are just 11 | lisp strings. But you know, they are sort of files. 12 | 13 | ``` common-lisp 14 | (in-program p) 15 | ``` 16 | 17 | This sets the value of *program* to the program `p`. 18 | 19 | # kernel function 20 | 21 | Now let's take a look at an example kernel function. 22 | 23 | ``` common-lisp 24 | (defkernel vec-add-kernel (void ((a float*) (b float*) (c float*))) 25 | (let ((i (get-global-id 0))) 26 | (set (aref c i) 27 | (+ (aref a i) (aref b i))))) 28 | ``` 29 | 30 | I first describe what this kernel actually does (although it is already intuitive). 31 | This is a function that takes three float arrays (pointers). 32 | `(get-global-id 0)` returns the unique global work-item ID on dimension 0 assigned to each thread. 33 | (Note that there is global id, local id, group id. See the OpenCL reference.) 34 | Thus, if you run the kernel, N=`(get-global-size 0)` elements of the vector `c` gets updated. 35 | 36 | Next I describe how this kernel is processed. 37 | The kernel function `vec-add-kernel` is registered to the program `p`. 38 | Macro expansion happens at this point, however this is still an S-exp, not the C code string. 39 | It really becomes a C code string when a function `compile-program` gets called. 40 | 41 | ``` common-lisp 42 | (compile-program (find-program 'p)) 43 | ``` 44 | 45 | This function returns an OpenCL C source code string, assembling every global 46 | variables and kernel functions defined in the program. 47 | 48 | Compiling this C code into a device-specific binary is a different story and it 49 | requires the involved explanation of OpenCL framework 50 | (CREATE-PROGRAM-WITH-SOURCE). This is clearly out of scope of this document. 51 | Instead, we describe how the S-expression is compiled into a C source code. 52 | 53 | # C code compilation process 54 | 55 | Gotcha! I don't describe it. Call graph should suffice! 56 | 57 | ![compile-program.png](./compile-program.png) 58 | -------------------------------------------------------------------------------- /src/api/defkernel.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage :oclcl.api.defkernel 9 | (:use :cl 10 | :oclcl.lang.syntax 11 | :oclcl.lang.type 12 | :oclcl.lang.program) 13 | (:export :defkernel 14 | :defmemory 15 | :defkernelmacro 16 | :defkernel-symbol-macro 17 | :defkernel-define) 18 | (:import-from :alexandria 19 | :format-symbol 20 | :with-gensyms 21 | :simple-style-warning) 22 | (:documentation 23 | "Defines some convenience wrapper macros that register the OpenCL objects, 24 | such as kernels, memory and kernel macros.")) 25 | (in-package :oclcl.api.defkernel) 26 | 27 | ;;; 28 | ;;; DEFKERNEL 29 | ;;; 30 | 31 | 32 | (defmacro defkernel (name (return-type arguments) &body body) 33 | "Register the kernel definition to *PROGRAM* ." 34 | `(program-define-function *program* 35 | ',name 36 | ',return-type 37 | ',arguments 38 | ',body)) 39 | 40 | ;;; DEFMEMORY 41 | ;;; 42 | 43 | (defmacro defmemory (name expression &optional qualifiers) 44 | "Register the name and the initialization statement of a global variable (stored in the global memory) 45 | to *PROGRAM* ." 46 | `(program-define-memory *program* 47 | ',name 48 | ',(or qualifiers :global) 49 | ',expression)) 50 | 51 | ;;; 52 | ;;; DEFKERNELMACRO 53 | ;;; 54 | 55 | (defmacro defkernelmacro (name arguments &body body) 56 | "Register the kernel macro definition to *PROGRAM* . 57 | For a macro which is not fbound, it tries to define the regular CL macro so that SLIME macroexpansion and 58 | eldoc works." 59 | (with-gensyms (e) 60 | `(progn 61 | ,(if (fboundp name) 62 | (simple-style-warning "Could not define the kernel macro ~a also as a regular macro, because it is fbound." name) 63 | `(defmacro ,name (,@arguments &environment ,e) 64 | (declare (ignorable ,e)) 65 | ,@body)) 66 | (program-define-macro *program* ',name ',arguments ',body)))) 67 | 68 | ;;; 69 | ;;; DEFKERNEL-SYMBOL-MACRO 70 | ;;; 71 | 72 | (defmacro defkernel-symbol-macro (name expansion) 73 | "Register the kernel symbol macro to *PROGRAM*." 74 | `(program-define-symbol-macro *program* ',name ',expansion)) 75 | 76 | ;;; DEFKERNEL-DEFINE 77 | ;;; 78 | 79 | (defmacro defkernel-define (name expression) 80 | "Register the define to *PROGRAM* ." 81 | `(program-define-define *program* 82 | ',name 83 | ',expression)) 84 | -------------------------------------------------------------------------------- /tests/lang/type.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.tests.lang.type 9 | (:use :cl :rove 10 | :oclcl.tests.utils 11 | :oclcl.lang.data 12 | :oclcl.lang.type) 13 | (:import-from #:serapeum 14 | #:fmt)) 15 | (in-package :oclcl.tests.lang.type) 16 | 17 | ;;; 18 | ;;; test OCLCL-TYPE-P function 19 | ;;; 20 | 21 | (deftest oclcl-type-p 22 | (dolist (type '(char uchar short ushort int uint long ulong)) 23 | (is (oclcl-type-p type) t (fmt "integer type : ~a" type))) 24 | (dolist (type '(float double)) 25 | (is (oclcl-type-p type) t (fmt "float type : ~a" type))) 26 | (is (oclcl-type-p 'int) t "basic case 1") 27 | (is (oclcl-type-p 'float3) t "basic case 2") 28 | (is (oclcl-type-p 'float3*) t "basic case 3") 29 | (is (oclcl-type-p '*float*) nil "basic case 4")) 30 | 31 | 32 | ;;; 33 | ;;; test CFFI-TYPE function 34 | ;;; 35 | 36 | (deftest cffi-type 37 | (is (cffi-type 'int) :int "basic case 1") 38 | (is (cffi-type 'float3) '(:struct float3) "basic case 2")) 39 | 40 | 41 | ;;; 42 | ;;; test CFFI-TYPE-SIZE function 43 | ;;; 44 | 45 | (deftest cffi-type-size 46 | (is (cffi-type-size 'int) 4 "basic case 1") 47 | (is (cffi-type-size 'float3) 12 "basic case 2")) 48 | 49 | 50 | ;;; 51 | ;;; test OPENCL-TYPE function 52 | ;;; 53 | 54 | (deftest opencl-type 55 | (is (opencl-type 'int) "int" "basic case 1") 56 | (is (opencl-type 'float3) "float3" "basic case 2") 57 | (is (opencl-type 'float3*) "__global float3*" "basic case 3")) 58 | 59 | 60 | ;;; 61 | ;;; test STRUCTURE-ACCESSOR-P function 62 | ;;; 63 | 64 | (deftest structure-accessor-p 65 | (is (structure-accessor-p 'float3-x) t "basic case 1") 66 | (is (structure-accessor-p 'float4-w) t "basic case 2") 67 | (is (structure-accessor-p 'float3-w) nil "basic case 3")) 68 | 69 | 70 | ;;; 71 | ;;; test STRUCTURE-ACCESSOR-OPENCL-ACCESSOR function 72 | ;;; 73 | 74 | (deftest structure-accessor-opencl-accessor 75 | (is (structure-accessor-opencl-accessor 'float3-x) "x" "basic case 1") 76 | (is (structure-accessor-opencl-accessor 'float4-w) "w" "basic case 2") 77 | (ok (signals (structure-accessor-opencl-accessor 'float3-w) 'simple-error) 78 | "ACCESSOR which is not an invalid accessor.")) 79 | 80 | ;;; 81 | ;;; test STRUCTURE-ACCESSOR-RETURN-TYPE function 82 | ;;; 83 | 84 | (deftest structure-accessor-return-type 85 | (is (structure-accessor-return-type 'float3-x) 'float "basic case 1") 86 | (is (structure-accessor-return-type 'double4-w) 'double "basic case 2") 87 | (ok (signals (structure-accessor-return-type 'float3-w) 'simple-error) 88 | "ACCESSOR which is not an invalid accessor.")) 89 | 90 | ;;; 91 | ;;; test ARRAY-TYPE-BASE function 92 | ;;; 93 | 94 | (deftest array-type-base 95 | (is (array-type-base 'int*) 'int 96 | "basic case 1") 97 | (is (array-type-base 'int**) 'int 98 | "basic case 2")) 99 | 100 | 101 | ;;; 102 | ;;; test ARRAY-TYPE-DIMENSION function 103 | ;;; 104 | 105 | (deftest array-type-dimension 106 | (is (array-type-dimension 'int*) 1 107 | "basic case 1") 108 | (is (array-type-dimension 'int**) 2 109 | "basic case 2")) 110 | -------------------------------------------------------------------------------- /tests/lang/built-in.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.tests.lang.built-in 9 | (:use :cl :rove 10 | :oclcl.tests.utils 11 | :oclcl.lang.type 12 | :oclcl.lang.data 13 | :oclcl.lang.built-in)) 14 | (in-package :oclcl.tests.lang.built-in) 15 | 16 | ;;; 17 | ;;; test BUILT-IN-FUNCTION-RETURN-TYPE function 18 | ;;; 19 | 20 | (deftest built-in-function-return-type 21 | (loop for (opes args ret) in '(((+ * - / mod) (int int) int) 22 | ((+ * - / mod) (int int) int) 23 | ((+ * - /) (float float) float) 24 | ((+ * - / mod) (int4 int4) int4) 25 | ((+ * - /) (float4 float4) float4) 26 | ((< > <= >=) (int int) bool) 27 | ((< > <= >=) (float4 float4) int4) 28 | ((< > <= >=) (double4 double4) long4) 29 | ((fmax fmin) (float4 float4) float4) 30 | ((fmax fmin) (float4 float) float4) 31 | ((fmax fmin) (double4 double4) double4) 32 | ((fmax fmin) (double4 double) double4) 33 | ((ilogb) (float4) int4) 34 | ((nan) (uint4) float4) 35 | ((nan) (uint) float) 36 | ((nan) (ulong4) double4) 37 | ((nan) (ulong) double) 38 | ((pown) (float4 int4) float4) 39 | ((pown) (float int) float) 40 | ((pown) (double4 int4) double4) 41 | ((pown) (double int) double) 42 | ((abs) (char4) uchar4) 43 | ((clamp) (uint uint uint) uint) 44 | ((clamp) (uint4 uint4 uint4) uint4) 45 | ((clamp) (uint4 uint uint) uint4) 46 | ((clamp) (float4 float4 float4) float4) 47 | ((clamp) (float4 float float) float4) 48 | ((upsample) (short4 ushort4) int4)) 49 | do (dolist (ope opes) 50 | (is (built-in-function-return-type ope args) ret)))) 51 | 52 | 53 | ;;; 54 | ;;; test BUILT-IN-FUNCTION-INFIX-P function 55 | ;;; 56 | 57 | (deftest built-in-function-infix-p 58 | (loop for (ope args) in '((+ (int int)) 59 | (+ (float3 float3)) 60 | (- (int int)) 61 | (mod (int int))) 62 | do (ok (built-in-function-infix-p ope args)))) 63 | 64 | ;;; 65 | ;;; test BUILT-IN-FUNCTION-C-NAME function 66 | ;;; 67 | 68 | (deftest built-in-function-c-name 69 | (loop for (ope args name) in '((+ (int int) "+") 70 | (+ (float3 float3) "+") 71 | (- (int int) "-") 72 | (mod (int int) "%") 73 | (printf (string) "printf") 74 | (printf (string int) "printf")) 75 | do (is (built-in-function-c-name ope args) name))) 76 | -------------------------------------------------------------------------------- /examples/shared-memory.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage oclcl-examples.shared-memory 8 | (:use :cl 9 | :oclcl 10 | :alexandria) 11 | (:export :main-shared-memory :main-global-memory)) 12 | (in-package :oclcl-examples.shared-memory) 13 | 14 | (setf oclcl:*show-messages* nil) 15 | 16 | (defmacro def-global-memory (n) 17 | (let ((name (symbolicate "GLOBAL-MEMORY-" (princ-to-string n)))) 18 | `(defkernel ,name (void ((a float*))) 19 | (let ((i (+ (* block-dim-x block-idx-x) thread-idx-x))) 20 | ,@(loop repeat n 21 | collect '(set (aref a i) (+ (aref a i) 1.0))))))) 22 | 23 | (def-global-memory 1000) 24 | (def-global-memory 2000) 25 | (def-global-memory 3000) 26 | (def-global-memory 4000) 27 | 28 | (defkernel global-memory (void ((a float*))) 29 | (let ((i (+ (* block-dim-x block-idx-x) thread-idx-x))) 30 | (set (aref a i) (+ (aref a i) 1.0)))) 31 | 32 | (defmacro def-shared-memory (n) 33 | (let ((name (symbolicate "SHARED-MEMORY-" (princ-to-string n)))) 34 | `(defkernel ,name (void ((a float*))) 35 | (let ((i (+ (* block-dim-x block-idx-x) thread-idx-x))) 36 | (with-shared-memory ((s float 16)) 37 | (set (aref s thread-idx-x) (aref a i)) 38 | ,@(loop repeat n 39 | collect '(set (aref s thread-idx-x) 40 | (+ (aref s thread-idx-x) 1.0))) 41 | (set (aref a i) (aref s thread-idx-x))))))) 42 | 43 | (def-shared-memory 1000) 44 | (def-shared-memory 2000) 45 | (def-shared-memory 3000) 46 | (def-shared-memory 4000) 47 | 48 | (defkernel shared-memory (void ((a float*))) 49 | (let ((i (+ (* block-dim-x block-idx-x) thread-idx-x))) 50 | (with-shared-memory ((s float 16)) 51 | (set (aref s thread-idx-x) (aref a i)) 52 | (set (aref s thread-idx-x) (+ (aref s thread-idx-x) 1.0)) 53 | (set (aref a i) (aref s thread-idx-x))))) 54 | 55 | (defun init (a n) 56 | (dotimes (i n) 57 | (setf (memory-block-aref a i) 0.0))) 58 | 59 | (defun verify (a n expected) 60 | (dotimes (i n) 61 | (unless (= (memory-block-aref a i) expected) 62 | (error (format nil "verification fault: ~A ~A" 63 | (memory-block-aref a i) expected)))) 64 | (format t "verification succeed.~%")) 65 | 66 | (defun main (func expected) 67 | (let ((n (* 256 256))) 68 | (with-cuda (0) 69 | (with-memory-blocks ((a 'float n)) 70 | (init a n) 71 | (sync-memory-block a :host-to-device) 72 | (time 73 | (dotimes (i 100) 74 | (funcall func a 75 | :grid-dim (list (/ n 16) 1 1) 76 | :block-dim '(16 1 1)) 77 | (synchronize-context))) 78 | (sync-memory-block a :device-to-host) 79 | (verify a n expected))))) 80 | 81 | (defun main-shared-memory () 82 | (format t "#shared-memory-1000~%") 83 | (main #'shared-memory-1000 100000.0) ; took 1.421 [sec] 84 | (format t "#shared-memory-2000~%") 85 | (main #'shared-memory-2000 200000.0) ; took 4.744 [sec] 86 | (format t "#shared-memory-3000~%") 87 | (main #'shared-memory-3000 300000.0) ; took 7.181 [sec] 88 | (format t "#shared-memory-4000~%") 89 | (main #'shared-memory-4000 400000.0) ; took 9,483 [sec] 90 | ) 91 | 92 | (defun main-global-memory () 93 | (format t "#global-memory-1000~%") 94 | (main #'global-memory-1000 100000.0) ; took 3.895 [sec] 95 | (format t "#global-memory-2000~%") 96 | (main #'global-memory-2000 200000.0) ; took 7.617 [sec] 97 | (format t "#global-memory-3000~%") 98 | (main #'global-memory-3000 300000.0) ; took 11.344 [sec] 99 | (format t "#global-memory-4000~%") 100 | (main #'global-memory-4000 400000.0) ; took 15.077 [sec] 101 | ) 102 | -------------------------------------------------------------------------------- /tests/lang/compiler/compile-program.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.tests.lang.compiler.compile-program 9 | (:use :cl :rove 10 | :oclcl.tests.utils 11 | :oclcl.lang.type 12 | :oclcl.lang.program 13 | :oclcl.lang.compiler.compile-program)) 14 | (in-package :oclcl.tests.lang.compiler.compile-program) 15 | 16 | ;;; 17 | ;;; test COMPILE-PROGRAM funcition 18 | ;;; 19 | 20 | (deftest compile-program 21 | (testing "empty env" 22 | (let ((program (make-program))) 23 | (is (compile-program program) ""))) 24 | 25 | (let ((program (make-program))) 26 | (program-define-define program 'charlie-delta 1.0) 27 | (program-define-define program 'echo-foxtrot '(+ 10 20)) 28 | (is (compile-program program) 29 | "/** 30 | * Define 31 | */ 32 | 33 | #define CHARLIE_DELTA 1.0f 34 | #define ECHO_FOXTROT (10 + 20) 35 | ")) 36 | 37 | (let ((program (make-program))) 38 | (program-define-memory program 'a :constant 1) 39 | (program-define-memory program 'b :global 1.0f0) 40 | (is (compile-program program) 41 | "/** 42 | * Memory objects 43 | */ 44 | 45 | __constant int oclcl_tests_lang_compiler_compile_program_a = 1; 46 | __global float oclcl_tests_lang_compiler_compile_program_b = 1.0f; 47 | ")) 48 | 49 | (let ((program (make-program))) 50 | (program-define-function program 'foo 'void '((x int*)) 51 | '((set (aref x 0) (bar 1)) 52 | (return))) 53 | (program-define-function program 'bar 'int '((x int)) '((return x))) 54 | (program-define-function program 'baz 'void '() '((return))) 55 | (is (compile-program program) 56 | "/** 57 | * Kernel function prototypes 58 | */ 59 | 60 | __kernel void oclcl_tests_lang_compiler_compile_program_foo(__global int* x); 61 | int oclcl_tests_lang_compiler_compile_program_bar(int x); 62 | __kernel void oclcl_tests_lang_compiler_compile_program_baz(); 63 | 64 | 65 | /** 66 | * Kernel function definitions 67 | */ 68 | 69 | __kernel void oclcl_tests_lang_compiler_compile_program_foo(__global int* x) 70 | { 71 | x[0] = oclcl_tests_lang_compiler_compile_program_bar(1); 72 | return; 73 | } 74 | 75 | int oclcl_tests_lang_compiler_compile_program_bar(int x) 76 | { 77 | return x; 78 | } 79 | 80 | __kernel void oclcl_tests_lang_compiler_compile_program_baz() 81 | { 82 | return; 83 | } 84 | ")) 85 | 86 | (let ((program (make-program))) 87 | (program-define-memory program 'a :constant 1) 88 | (program-define-memory program 'b :global 1.0f0) 89 | (program-define-function program 'foo 'void '((x int*)) 90 | '((set (aref x 0) (bar 1)) 91 | (return))) 92 | (program-define-function program 'bar 'int '((x int)) '((return x))) 93 | (program-define-function program 'baz 'void '() '((return))) 94 | (program-define-define program 'charlie-delta 1.0) 95 | (program-define-define program 'echo-foxtrot '(+ 10 20)) 96 | (is (compile-program program) 97 | "/** 98 | * Define 99 | */ 100 | 101 | #define CHARLIE_DELTA 1.0f 102 | #define ECHO_FOXTROT (10 + 20) 103 | 104 | 105 | /** 106 | * Memory objects 107 | */ 108 | 109 | __constant int oclcl_tests_lang_compiler_compile_program_a = 1; 110 | __global float oclcl_tests_lang_compiler_compile_program_b = 1.0f; 111 | 112 | 113 | /** 114 | * Kernel function prototypes 115 | */ 116 | 117 | __kernel void oclcl_tests_lang_compiler_compile_program_foo(__global int* x); 118 | int oclcl_tests_lang_compiler_compile_program_bar(int x); 119 | __kernel void oclcl_tests_lang_compiler_compile_program_baz(); 120 | 121 | 122 | /** 123 | * Kernel function definitions 124 | */ 125 | 126 | __kernel void oclcl_tests_lang_compiler_compile_program_foo(__global int* x) 127 | { 128 | x[0] = oclcl_tests_lang_compiler_compile_program_bar(1); 129 | return; 130 | } 131 | 132 | int oclcl_tests_lang_compiler_compile_program_bar(int x) 133 | { 134 | return x; 135 | } 136 | 137 | __kernel void oclcl_tests_lang_compiler_compile_program_baz() 138 | { 139 | return; 140 | } 141 | "))) 142 | -------------------------------------------------------------------------------- /tests/api/defkernel.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage :oclcl.tests.api.defkernel 9 | (:use :cl :rove 10 | :oclcl.tests.utils 11 | :oclcl.api.defkernel 12 | :oclcl.lang 13 | :oclcl.lang.program 14 | :oclcl.lang.compiler.compile-program) 15 | (:import-from :oclcl.api.defkernel)) 16 | (in-package :oclcl.tests.api.defkernel) 17 | 18 | (defmacro with-stub-program (&body body) 19 | `(let ((oclcl.lang.program:*program* (oclcl.lang.program:make-program))) 20 | ,@body)) 21 | 22 | ;;; 23 | ;;; test DEFKERNEL macro 24 | ;;; 25 | 26 | ;; test "let1" kernel 27 | (defkernel let1 (void ()) 28 | (let ((i 0)) 29 | (return)) 30 | (let ((i 0)))) 31 | 32 | ; test "use-one" kernel 33 | (defkernel one (int ()) 34 | (return 1)) 35 | 36 | (defkernel use-one (void ()) 37 | (let ((i (one))) 38 | (return))) 39 | 40 | ;; test "argument" kernel 41 | (defkernel argument (void ((i int) (j float3))) 42 | (return)) 43 | 44 | ;; test "kernel-bool" kernel 45 | (defkernel kernel-bool (void ((a bool*))) 46 | (set (aref a 0) t) 47 | (set (aref a 1) nil) 48 | (return)) 49 | 50 | ;; test "kernel-float3" kernel 51 | (defkernel kernel-float3 (void ((a float*) (x float3))) 52 | (set (aref a 0) (+ (float3-x x) (float3-y x) (float3-z x)))) 53 | 54 | ;; test DO statement 55 | (defkernel test-do-kernel (void ((x int*))) 56 | (do ((i 0 (+ i 1))) 57 | ((> i 15)) 58 | (set (aref x 0) (+ (aref x 0) 1)))) 59 | 60 | ;;; test DEFMEMORY macro 61 | ;;; 62 | 63 | (deftest defmemory 64 | (with-stub-program 65 | (defmemory a 42 :constant) 66 | (defmemory b 0 :global) 67 | (is (compile-program *program*) 68 | "/** 69 | * Memory objects 70 | */ 71 | 72 | __constant int oclcl_tests_api_defkernel_a = 42; 73 | __global int oclcl_tests_api_defkernel_b = 0; 74 | " "work defmemory"))) 75 | 76 | ;;; 77 | ;;; test DEFKERNELMACRO macro 78 | ;;; 79 | 80 | (deftest defkernelmacro 81 | (with-stub-program 82 | 83 | (defkernelmacro alfa (test &body forms) 84 | `(if ,test 85 | (progn ,@forms))) 86 | 87 | (defkernel test-alfa (void ()) 88 | (alfa t (return)) 89 | (return)) 90 | 91 | (is (compile-program *program*) 92 | "/** 93 | * Kernel function prototypes 94 | */ 95 | 96 | __kernel void oclcl_tests_api_defkernel_test_alfa(); 97 | 98 | 99 | /** 100 | * Kernel function definitions 101 | */ 102 | 103 | __kernel void oclcl_tests_api_defkernel_test_alfa() 104 | { 105 | if (true) 106 | { 107 | return; 108 | } 109 | return; 110 | } 111 | " "work defkernelmacro"))) 112 | 113 | ;;; 114 | ;;; test DEFKERNEL-SYMBOL-MACRO macro 115 | ;;; 116 | 117 | (deftest defkernel-symbol-macro 118 | (with-stub-program 119 | 120 | (defkernel-symbol-macro x 1) 121 | 122 | (defkernel test-symbol-macro (void ((ret int*))) 123 | (set (aref ret 0) x) 124 | (return)) 125 | 126 | (is (compile-program *program*) 127 | "/** 128 | * Kernel function prototypes 129 | */ 130 | 131 | __kernel void oclcl_tests_api_defkernel_test_symbol_macro(__global int* ret); 132 | 133 | 134 | /** 135 | * Kernel function definitions 136 | */ 137 | 138 | __kernel void oclcl_tests_api_defkernel_test_symbol_macro(__global int* ret) 139 | { 140 | ret[0] = 1; 141 | return; 142 | } 143 | " "work defkernel-symbol-macro"))) 144 | 145 | 146 | ;;; 147 | ;;; test EXPAND-MACRO function 148 | ;;; 149 | 150 | (deftest expand-macro 151 | (defkernelmacro foo (x) 152 | `(return ,x)) 153 | 154 | (defkernelmacro bar (x) 155 | `(foo ,x)) 156 | 157 | (defkernel-symbol-macro a 1.0) 158 | 159 | (defkernel-symbol-macro b a) 160 | 161 | (testing "exapnd-macro-1" 162 | (is-values (expand-macro-1 '(foo 1)) '((return 1) t)) 163 | (is-values (expand-macro-1 '(bar 1)) '((foo 1) t)) 164 | (is-values (expand-macro-1 '(baz 1)) '((baz 1) nil)) 165 | (is-values (expand-macro-1 'a) '(1.0 t)) 166 | (is-values (expand-macro-1 'b) '(a t)) 167 | (is-values (expand-macro-1 'c) '(c nil)) 168 | (ok (signals (expand-macro-1 '(foo)) 'error))) 169 | 170 | (testing "exapnd-macro" 171 | (is-values (expand-macro '(foo 1)) '((return 1) t)) 172 | (is-values (expand-macro '(bar 1)) '((return 1) t)) 173 | (is-values (expand-macro '(baz 1)) '((baz 1) nil)) 174 | (is-values (expand-macro 'a) '(1.0 t)) 175 | (is-values (expand-macro 'b) '(1.0 t)) 176 | (is-values (expand-macro 'c) '(c nil)) 177 | (ok (signals (expand-macro '(foo)) 'error)))) 178 | -------------------------------------------------------------------------------- /src/lang/lang.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage :oclcl.lang 9 | (:use :cl 10 | :cl-reexport) 11 | (:documentation " 12 | Exports the symbols for writing OpenCL programs. 13 | APIs for manipulating those programs (e.g. compiling, lookup...) are not exported from this package.")) 14 | (in-package :oclcl.lang) 15 | 16 | 17 | 18 | ;; reexport symbols of data structures oclcl provides 19 | (reexport-from :oclcl.lang.data 20 | :include '(;; Float3 21 | :float3 22 | :make-float3 23 | :float3-x 24 | :float3-y 25 | :float3-z 26 | :float3-p 27 | :float3-= 28 | ;; Float4 29 | :float4 30 | :make-float4 31 | :float4-x 32 | :float4-y 33 | :float4-z 34 | :float4-w 35 | :float4-p 36 | :float4-= 37 | ;; Double3 38 | :double3 39 | :make-double3 40 | :double3-x 41 | :double3-y 42 | :double3-z 43 | :double3-p 44 | :double3-= 45 | ;; Double4 46 | :double4 47 | :make-double4 48 | :double4-x 49 | :double4-y 50 | :double4-z 51 | :double4-w 52 | :double4-p 53 | :double4-=)) 54 | 55 | ;; reexport symbols of oclcl types 56 | ;; OpenCL v1.2 dr19: 6.1 Supported Data Type 57 | (reexport-from :oclcl.lang.type 58 | :include '(:bool 59 | :bool* 60 | :char :char2 :char3 :char4 :char8 :char16 61 | :char* :char2* :char3* :char4* :char8* :char16* 62 | :uchar :uchar2 :uchar3 :uchar4 :uchar8 :uchar16 63 | :uchar* :uchar2* :uchar3* :uchar4* :uchar8* :uchar16* 64 | :short :short2 :short3 :short4 :short8 :short16 65 | :short* :short2* :short3* :short4* :short8* :short16* 66 | :ushort :ushort2 :ushort3 :ushort4 :ushort8 :ushort16 67 | :ushort* :ushort2* :ushort3* :ushort4* :ushort8* :ushort16* 68 | :int :int2 :int3 :int4 :int8 :int16 69 | :int* :int2* :int3* :int4* :int8* :int16* 70 | :uint :uint2 :uint3 :uint4 :uint8 :uint16 71 | :uint* :uint2* :uint3* :uint4* :uint8* :uint16* 72 | :long :long2 :long3 :long4 :long8 :long16 73 | :long* :long2* :long3* :long4* :long8* :long16* 74 | :ulong :ulong2 :ulong3 :ulong4 :ulong8 :ulong16 75 | :ulong* :ulong2* :ulong3* :ulong4* :ulong8* :ulong16* 76 | ;:float :float2 :float3 :float4 :float8 :float16 77 | :float :float2 :float8 :float16 78 | :float* :float2* :float3* :float4* :float8* :float16* 79 | ;:double :double2 :double3 :double4 :double8 :double16 80 | :double :double2 :double8 :double16 81 | :double* :double2* :double3* :double4* :double8* :double16* 82 | :half 83 | :size-t 84 | :ptrdiff-t 85 | :intptr-t 86 | :uintptr-t 87 | :void 88 | :cl-mem-fence-flags)) 89 | 90 | ;; reexport symbols of oclcl syntax except the ones exported 91 | ;; from COMMON-LISP package 92 | (reexport-from :oclcl.lang.syntax 93 | :include '(:clk-local-mem-fence 94 | :clk-global-mem-fence 95 | :with-local-memory 96 | :set 97 | :sizeof)) 98 | 99 | ;; reexport symbols of oclcl built-in functions except the ones 100 | ;; exported from COMMON-LISP package 101 | (reexport-from :oclcl.lang.built-in) 102 | 103 | 104 | -------------------------------------------------------------------------------- /examples/vector-add.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2016 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | #| 8 | This file is based on the CUDA SDK's "vectorAdd" sample. 9 | |# 10 | 11 | (in-package :cl-user) 12 | (defpackage oclcl-examples.vector-add 13 | (:use :cl 14 | :oclcl 15 | :cffi 16 | :eazy-opencl.host) 17 | (:export :main)) 18 | (in-package :oclcl-examples.vector-add) 19 | 20 | (define-program :vector-add-eazyopencl 21 | (:use :oclcl)) 22 | (in-program :vector-add-eazyopencl) 23 | 24 | (defun random-init (data n) 25 | (dotimes (i n) 26 | (let ((r (random 1.0))) 27 | (setf (mem-aref data :float i) r)))) 28 | 29 | (defun zero-init (data n) 30 | (dotimes (i n) 31 | (setf (mem-aref data :float i) 0.0))) 32 | 33 | (defun verify-result (as bs cs n) 34 | (dotimes (i n) 35 | (let ((a (mem-aref as :float i)) 36 | (b (mem-aref bs :float i)) 37 | (c (mem-aref cs :float i))) 38 | (let ((sum (+ a b))) 39 | (when (> (abs (- c sum)) 1.0) 40 | (error (format nil "verification fault, i:~A a:~A b:~A c:~A" 41 | i a b c)))))) 42 | (format t "verification succeed.~%")) 43 | 44 | (defkernel vec-add-kernel (void ((a float*) (b float*) (c float*))) 45 | (let ((i (get-global-id 0))) 46 | (set (aref c i) 47 | (+ (aref a i) (aref b i))))) 48 | 49 | (defvar *vector-add* " 50 | 51 | __kernel void oclcl_examples_vector_add_vec_add_kernel( __global float* a, __global float* b, __global float* c ) 52 | { 53 | size_t i = get_global_id( 0 ); 54 | c[i] = (a[i] + b[i]); 55 | } 56 | 57 | ") 58 | 59 | (defun main () 60 | (let* ((platform-id (car (get-platform-ids))) 61 | (devices (get-device-ids platform-id :device-type-default)) 62 | (context (create-context devices)) 63 | (command-queue (create-command-queue context (first devices) 0)) 64 | (*program* (find-program :vector-add-eazyopencl)) 65 | (c-source-code (compile-program *program*)) 66 | (program 67 | (create-program-with-source context c-source-code) 68 | #+nil 69 | (create-program-with-source context *vector-add*)) 70 | (elements 128) 71 | (float-size (foreign-type-size :float)) 72 | (data-bytes (* float-size elements))) 73 | (with-foreign-objects ((a-host :float elements) 74 | (b-host :float elements) 75 | (c-host :float elements)) 76 | (random-init a-host elements) 77 | (random-init b-host elements) 78 | (zero-init c-host elements) 79 | (let* ((a-device (create-buffer context :mem-read-only data-bytes)) 80 | (b-device (create-buffer context :mem-read-only data-bytes)) 81 | (c-device (create-buffer context :mem-read-only data-bytes))) 82 | (%ocl:enqueue-write-buffer command-queue 83 | a-device 84 | %ocl:true 85 | 0 86 | data-bytes 87 | a-host 88 | 0 89 | (null-pointer) 90 | (null-pointer)) 91 | (%ocl:enqueue-write-buffer command-queue 92 | b-device 93 | %ocl:true 94 | 0 95 | data-bytes 96 | b-host 97 | 0 98 | (null-pointer) 99 | (null-pointer)) 100 | (%ocl/h::with-foreign-array (global-work-size '%ocl:size-t (list elements)) 101 | (build-program program :devices devices) 102 | (let ((kernel 103 | (create-kernel program "oclcl_examples_vector_add_vec_add_kernel") 104 | #+nil 105 | (create-kernel program "hello"))) 106 | (set-kernel-arg kernel 0 a-device '%ocl:mem) 107 | (set-kernel-arg kernel 1 b-device '%ocl:mem) 108 | (set-kernel-arg kernel 2 c-device '%ocl:mem) 109 | (%ocl:enqueue-nd-range-kernel command-queue 110 | kernel 111 | 1 112 | (null-pointer) 113 | global-work-size 114 | (null-pointer) 115 | 0 116 | (null-pointer) 117 | (null-pointer)))) 118 | (%ocl:enqueue-read-buffer command-queue 119 | c-device 120 | %ocl:true 121 | 0 122 | data-bytes 123 | c-host 124 | 0 125 | (null-pointer) 126 | (null-pointer))) 127 | (verify-result a-host b-host c-host elements)))) 128 | -------------------------------------------------------------------------------- /examples/vector-add-oclapi.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2016 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | #| 8 | This file is based on the CUDA SDK's "vectorAdd" sample. 9 | |# 10 | 11 | (in-package :cl-user) 12 | (defpackage oclcl-examples.vector-add-oclapi 13 | (:use :cl 14 | :cffi 15 | :oclcl) 16 | (:import-from :cl-oclapi 17 | :with-platform-id 18 | :with-device-ids 19 | :with-context 20 | :with-program-with-source 21 | :with-command-queue 22 | :with-buffer 23 | :with-buffers 24 | :with-work-size 25 | :with-kernel 26 | :with-pointers 27 | :cl-size 28 | :cl-device-id 29 | :enqueue-read-buffer 30 | :enqueue-write-buffer 31 | :set-kernel-arg 32 | :enqueue-ndrange-kernel 33 | :build-program 34 | :finish 35 | :+cl-true+ 36 | :+cl-mem-read-only+ 37 | :+cl-mem-write-only+) 38 | (:export :main)) 39 | (in-package :oclcl-examples.vector-add-oclapi) 40 | 41 | (define-program :vector-add-oclapi 42 | (:use :oclcl)) 43 | (in-program :vector-add-oclapi) 44 | 45 | (defun random-init (data n) 46 | (dotimes (i n) 47 | (let ((r (random 1.0))) 48 | (setf (mem-aref data :float i) r)))) 49 | 50 | (defun zero-init (data n) 51 | (dotimes (i n) 52 | (setf (mem-aref data :float i) 0.0))) 53 | 54 | (defun verify-result (as bs cs n) 55 | (dotimes (i n) 56 | (let ((a (mem-aref as :float i)) 57 | (b (mem-aref bs :float i)) 58 | (c (mem-aref cs :float i))) 59 | (let ((sum (+ a b))) 60 | (when (> (abs (- c sum)) 1.0) 61 | (error (format nil "verification fault, i:~A a:~A b:~A c:~A" 62 | i a b c)))))) 63 | (format t "verification succeed.~%")) 64 | 65 | (defkernel vec-add-kernel (void ((a float*) (b float*) (c float*))) 66 | (let ((i (get-global-id 0))) 67 | (set (aref c i) 68 | (+ (aref a i) (aref b i))))) 69 | 70 | (defvar *vector-add* " 71 | 72 | __kernel void oclcl_examples_vector_add_vec_add_kernel( __global float* a, __global float* b, __global float* c ) 73 | { 74 | size_t i = get_global_id( 0 ); 75 | c[i] = (a[i] + b[i]); 76 | } 77 | 78 | ") 79 | 80 | (defun main () 81 | (with-platform-id (platform) 82 | (with-device-ids (devices num-devices platform) 83 | (with-context (context (null-pointer) 1 devices) 84 | (let* ((*program* (find-program :vector-add-oclapi)) 85 | (c-source-code (compile-program *program*)) 86 | (device (mem-aref devices 'cl-device-id))) 87 | (with-program-with-source (program context 1 c-source-code) 88 | (build-program program 1 devices) 89 | (let* ((elements 128) 90 | (float-size (foreign-type-size :float)) 91 | (data-bytes (* float-size elements))) 92 | (with-foreign-objects ((a-host :float elements) 93 | (b-host :float elements) 94 | (c-host :float elements)) 95 | (random-init a-host elements) 96 | (random-init b-host elements) 97 | (zero-init c-host elements) 98 | (with-buffers ((a-device context +cl-mem-read-only+ data-bytes) 99 | (b-device context +cl-mem-read-only+ data-bytes) 100 | (c-device context +cl-mem-write-only+ data-bytes)) 101 | (with-command-queue (command-queue context device 0) 102 | (enqueue-write-buffer command-queue 103 | a-device 104 | +cl-true+ 105 | 0 106 | data-bytes 107 | a-host) 108 | (enqueue-write-buffer command-queue 109 | b-device 110 | +cl-true+ 111 | 0 112 | data-bytes 113 | b-host) 114 | (finish command-queue) 115 | (with-work-size (global-work-size elements) 116 | (with-kernel (kernel program (program-function-c-name *program* 'vec-add-kernel)) 117 | (with-pointers ((a-pointer a-device) 118 | (b-pointer b-device) 119 | (c-pointer c-device)) 120 | (set-kernel-arg kernel 0 8 a-pointer) 121 | (set-kernel-arg kernel 1 8 b-pointer) 122 | (set-kernel-arg kernel 2 8 c-pointer) 123 | (enqueue-ndrange-kernel command-queue 124 | kernel 125 | 1 126 | global-work-size 127 | (null-pointer)) 128 | (enqueue-read-buffer command-queue 129 | c-device 130 | +cl-true+ 131 | 0 132 | data-bytes 133 | c-host) 134 | (finish command-queue) 135 | (verify-result a-host b-host c-host elements)))))))))))))) 136 | -------------------------------------------------------------------------------- /tests/lang/compiler/type-of-expression.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.tests.lang.compiler.type-of-expression 9 | (:use :cl :rove 10 | :oclcl.tests.utils 11 | :oclcl.lang.compiler.type-of-expression 12 | :oclcl.lang.data 13 | :oclcl.lang.type 14 | :oclcl.lang.syntax 15 | :oclcl.lang.environment 16 | :oclcl.lang.built-in) 17 | (:import-from :oclcl.lang.compiler.type-of-expression 18 | :type-of-macro 19 | :type-of-symbol-macro 20 | :type-of-literal 21 | :type-of-reference 22 | :type-of-inline-if 23 | :type-of-arithmetic 24 | :type-of-function 25 | :type-of-sizeof) 26 | (:import-from :arrow-macros 27 | :->>)) 28 | 29 | (in-package :oclcl.tests.lang.compiler.type-of-expression) 30 | 31 | ;;; 32 | ;;; test TYPE-OF-EXPRESSION function 33 | ;;; 34 | 35 | (deftest type-of-expression 36 | (with-empty-env (env) 37 | (is (type-of-expression 1 env) 'int))) 38 | 39 | ;;; 40 | ;;; test TYPE-OF-MACRO function 41 | ;;; 42 | 43 | (deftest type-of-macro 44 | (with-empty-env (env) 45 | (setf env (function-environment-add-macro 'alfa '(x) '(x) env)) 46 | (is (type-of-macro '(alfa "bravo") env) 'string))) 47 | 48 | ;;; 49 | ;;; test TYPE-OF-SYMBOL-MACRO function 50 | ;;; 51 | 52 | (deftest type-of-symbol-macro 53 | (with-empty-env (env) 54 | (setf env (variable-environment-add-symbol-macro 'alfa "bravo" env)) 55 | (is (type-of-symbol-macro 'alfa env) 'string))) 56 | 57 | 58 | ;;; 59 | ;;; test TYPE-OF-LITERAL function 60 | ;;; 61 | 62 | (deftest type-of-literal 63 | 64 | (is (type-of-literal t) 'bool 65 | "basic case 1") 66 | 67 | (is (type-of-literal nil) 'bool 68 | "basic case 2") 69 | 70 | (is (type-of-literal 1) 'int 71 | "basic case 3") 72 | 73 | (is (type-of-literal 1.0f0) 'float 74 | "basic case 4") 75 | 76 | (is (type-of-literal 1.0d0) 'double 77 | "basic case 5")) 78 | 79 | 80 | ;;; 81 | ;;; test TYPE-OF-REFERENCE function 82 | ;;; 83 | 84 | (deftest type-of-reference-variable 85 | (with-empty-env (env) 86 | (setf env (->> env 87 | (variable-environment-add-variable 'x 'int) 88 | (variable-environment-add-symbol-macro 'y 'y-expansion) 89 | (variable-environment-add-variable 'y-expansion 'float) 90 | (variable-environment-add-memory 'z 'int 1))) 91 | (is (type-of-reference 'x env) 'int 92 | "basic case 1") 93 | (is (type-of-reference 'z env) 'int 94 | "basic caase 2") 95 | (ok (signals (type-of-reference 'y env) 'simple-error) 96 | "FORM which is a variable not found.") 97 | (ok (signals (type-of-reference 'a env) 'simple-error) 98 | "FORM which is a variable not found."))) 99 | 100 | 101 | (deftest type-of-reference-structure 102 | (with-empty-env (env) 103 | (setf env (variable-environment-add-variable 'x 'float3 env)) 104 | (is (type-of-reference '(float3-x x) env) 'float) 105 | (is (type-of-reference '(float3-y x) env) 'float) 106 | (ok (signals (type-of-reference '(float4-x x) env) 107 | 'simple-error)))) 108 | 109 | 110 | (deftest type-of-reference-array 111 | (with-empty-env (env) 112 | (setf env (variable-environment-add-variable 'x 'int env)) 113 | (ok (signals (type-of-reference '(aref x) env) 'simple-error))) 114 | 115 | (with-empty-env (env) 116 | (setf env (variable-environment-add-variable 'x 'int* env)) 117 | (is (type-of-reference '(aref x 0) env) 'int) 118 | (ok (signals (type-of-reference '(aref x 0 0) env) 119 | 'simple-error))) 120 | 121 | (with-empty-env (env) 122 | (setf env (variable-environment-add-variable 'x 'int** env)) 123 | (ok (signals (type-of-reference '(aref x 0) env) 'simple-error)) 124 | (is (type-of-reference '(aref x 0 0) env) 'int))) 125 | 126 | 127 | ;;; 128 | ;;; test TYPE-OF-INLINE-IF function 129 | ;;; 130 | 131 | (deftest type-of-inline-if 132 | 133 | (with-empty-env (env) 134 | (ok (signals (type-of-inline-if '(if) env) 135 | 'simple-error) 136 | "only if") 137 | (ok (signals (type-of-inline-if '(if (= 1 1)) env) 138 | 'simple-error) 139 | "test") 140 | (ok (signals (type-of-inline-if '(if (= 1 1) 1) env) 141 | 'simple-error) 142 | "test and then") 143 | (is (type-of-inline-if '(if (= 1 1) 1 2) env) 144 | 'int 145 | "valid if expression") 146 | (ok (signals (type-of-inline-if '(if 1 2 3) env) 147 | 'simple-error) 148 | "test is not bool") 149 | (ok (signals (type-of-inline-if '(if (= 1 1) 1 2.0) env) 150 | 'simple-error) 151 | "different type"))) 152 | 153 | 154 | ;;; 155 | ;;; test TYPE-OF-ARITHMETIC function 156 | ;;; 157 | 158 | (deftest type-of-arithmetic 159 | (with-empty-env (env) 160 | (ok (type-of-arithmetic '(+ 1 2) env) "arithmetic +"))) 161 | 162 | 163 | ;;; 164 | ;;; test TYPE-OF-FUNCTION function 165 | ;;; 166 | 167 | (deftest type-of-function 168 | (with-empty-env (env) 169 | (setf env (function-environment-add-function 'foo 'int '(int int) env)) 170 | (is (type-of-function '(+ 1 1) env) 'int) 171 | (is (type-of-function '(foo 1 1) env) 'int) 172 | (is (type-of-function '(+ 1.0f0 1.0f0) env) 'float) 173 | (ok (signals (type-of-function '(+ 1 1.0f0) env) 'simple-error)) 174 | (is (type-of-function '(pow 1.0f0 1.0f0) env) 'float) 175 | (is (type-of-function '(half-cos 1.0f0) env) 'float) 176 | (ok (signals (type-of-function '(half-divide 1.0) env) 'simple-error)) 177 | (is (type-of-function '(native-cos 1.0f0) env) 'float) 178 | (ok (signals (type-of-function '(native-divide 1.0) env) 'simple-error)) 179 | (is (type-of-function '(popcount 1) env) 'int) 180 | (is (type-of-function '(degrees 1.0f0) env) 'float))) 181 | 182 | ;;; 183 | ;;; test TYPE-OF-SIZEOF function 184 | ;;; 185 | 186 | (deftest type-of-sizeof 187 | (with-empty-env (env) 188 | (setf env (variable-environment-add-variable 'alfa 'int env)) 189 | (is (type-of-sizeof '(sizeof alfa) env) 'size-t) 190 | (is (type-of-sizeof '(sizeof double) env) 'size-t))) -------------------------------------------------------------------------------- /examples/diffuse0.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2016 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl-examples.diffuse0 9 | (:use :cl 10 | :cffi 11 | :oclcl 12 | :eazy-opencl.host) 13 | (:export :main)) 14 | (in-package :oclcl-examples.diffuse0) 15 | 16 | (define-program :diffuse0-eazyopencl 17 | (:use :oclcl)) 18 | (in-program :diffuse0-eazyopencl) 19 | 20 | ;;; image output functions 21 | 22 | (declaim (inline index)) 23 | (defun index (nx jx jy) 24 | (the fixnum (+ (the fixnum (* nx jy)) jx))) 25 | 26 | (defun image-value (f i j nx fmax fmin) 27 | (let ((fc (memory-block-aref f (index nx i j)))) 28 | (truncate (* 256.0 29 | (/ (- fc fmin) (- fmax fmin)))))) 30 | 31 | (defun file-name (dir i nout) 32 | (let ((n (truncate (/ i nout)))) 33 | (concatenate 'string dir (format nil "~4,'0D.pgm" n)))) 34 | 35 | (defun output-pnm (dir i nout nx ny f) 36 | (let ((image (make-instance 'imago:grayscale-image 37 | :width nx :height ny))) 38 | (dotimes (i nx) 39 | (dotimes (j ny) 40 | (setf (imago:image-pixel image i j) (image-value f i j nx 1.0 0.0)))) 41 | (imago:write-pnm image (file-name dir i nout) :ASCII)) 42 | (values)) 43 | 44 | 45 | ;;; print functions 46 | 47 | (defun print-elapsed-time (elapsed-time) 48 | (let ((time (* elapsed-time 1.0e-3))) 49 | (format t "Elapsed Time = ~,3F [sec]~%" time))) 50 | 51 | (defun print-performance (flo elapsed-time) 52 | (let ((time (* elapsed-time 1.0e-3))) 53 | (format t "Performance = ~,2F [MFlops]~%" (* (/ flo time) 1.0e-6)))) 54 | 55 | (defun print-time (cnt time) 56 | (format t "time(~A) = ~,5F~%" cnt time)) 57 | 58 | 59 | ;;; main functions 60 | 61 | (defkernel diffusion2d (void ((f float*) (fn float*) 62 | (nx int) (ny int) 63 | (c0 float) (c1 float) (c2 float))) 64 | (let* ((jy (to-int (get-global-id 1))) 65 | (jx (to-int (get-global-id 0))) 66 | (j (+ (* nx jy) jx))) 67 | (let ((fcc (aref f j)) 68 | (fcw 0.0) 69 | (fce 0.0) 70 | (fcs 0.0) 71 | (fcn 0.0)) 72 | (if (= jx 0) 73 | (set fcw fcc) 74 | (set fcw (aref f (- j 1)))) 75 | (if (= jx (- nx 1)) 76 | (set fce fcc) 77 | (set fce (aref f (+ j 1)))) 78 | (if (= jy 0) 79 | (set fcs fcc) 80 | (set fcs (aref f (- j nx)))) 81 | (if (= jy (- ny 1)) 82 | (set fcn fcc) 83 | (set fcn (aref f (+ j nx)))) 84 | (set (aref fn j) (+ (* c0 (+ fce fcw)) 85 | (* c1 (+ fcn fcs)) 86 | (* c2 fcc)))))) 87 | 88 | (defun initialize-device-memory (nx ny dx dy command-queue host-memory device-memory) 89 | (let ((alpha 30.0)) 90 | (dotimes (jy ny) 91 | (dotimes (jx nx) 92 | (let ((j (index nx jx jy)) 93 | (x (- (* dx (+ (float jx 1.0) 0.5)) 0.5)) 94 | (y (- (* dy (+ (float jy 1.0) 0.5)) 0.5))) 95 | (setf (mem-aref host-memory :float j) 96 | (exp (* (- alpha) 97 | (+ (* x x) (* y y))))))))) 98 | (%ocl:enqueue-write-buffer command-queue 99 | device-memory 100 | %ocl:true 101 | 0 102 | (* (foreign-type-size :float) 103 | (* nx ny)) 104 | host-memory 105 | 0 106 | (null-pointer) 107 | (null-pointer))) 108 | 109 | (defun diffusion2d (nx ny command-queue kernel f fn kappa dt dx dy) 110 | (let* ((c0 (* kappa (/ dt (* dx dx)))) 111 | (c1 (* kappa (/ dt (* dy dy)))) 112 | (c2 (- 1.0 (* 2.0 (+ c0 c1))))) 113 | (%ocl/h::with-foreign-array (global-work-size '%ocl:size-t (list nx ny)) 114 | (set-kernel-arg kernel 0 f '%ocl:mem) 115 | (set-kernel-arg kernel 1 fn '%ocl:mem) 116 | (set-kernel-arg kernel 2 nx :int) 117 | (set-kernel-arg kernel 3 ny :int) 118 | (set-kernel-arg kernel 4 c0 :float) 119 | (set-kernel-arg kernel 5 c1 :float) 120 | (set-kernel-arg kernel 6 c2 :float) 121 | (%ocl:enqueue-nd-range-kernel command-queue 122 | kernel 123 | 2 124 | (null-pointer) 125 | global-work-size 126 | (null-pointer) 127 | 0 128 | (null-pointer) 129 | (null-pointer))) 130 | (%ocl:finish command-queue) 131 | (* nx ny 7.0))) 132 | 133 | (defmacro swap (a b) 134 | `(rotatef ,a ,b)) 135 | 136 | (defun main () 137 | (let* ((nx 256) (ny 256) 138 | (Lx 1.0) (Ly 1.0) 139 | (dx (/ Lx (float nx 1.0))) 140 | (dy (/ Ly (float ny 1.0))) 141 | (kappa 0.1) 142 | (dt (/ (* 0.2 (min (* dx dx) (* dy dy))) kappa)) 143 | (time 0) 144 | (flo 0) 145 | (platform-id (car (get-platform-ids))) 146 | (devices (get-device-ids platform-id :device-type-default)) 147 | (context (create-context devices)) 148 | (command-queue (create-command-queue context (car devices) 0)) 149 | (*program* (find-program :diffuse0-eazyopencl)) 150 | (c-source-code (compile-program *program*)) 151 | (program (create-program-with-source context c-source-code)) 152 | (elements (* nx ny)) 153 | (float-size (foreign-type-size :float)) 154 | (data-bytes (* float-size elements))) 155 | (with-foreign-objects ((a-host :float elements)) 156 | (let* ((a-device (create-buffer context :mem-read-only data-bytes)) 157 | (b-device (create-buffer context :mem-read-only data-bytes))) 158 | (initialize-device-memory nx ny dx dy command-queue a-host a-device) 159 | (build-program program :devices devices) 160 | (let ((kernel (create-kernel program "oclcl_examples_diffuse0_diffusion2d"))) 161 | (dotimes (i 20000) 162 | (when (= (mod i 100) 0) 163 | (print-time i time)) 164 | (incf flo (diffusion2d nx ny command-queue kernel a-device b-device kappa dt dx dy)) 165 | (incf time dt) 166 | (swap a-device b-device))))))) 167 | -------------------------------------------------------------------------------- /src/lang/data.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.lang.data 9 | (:use :cl) 10 | (:export ;; Symbol 11 | :oclcl-symbol 12 | :oclcl-symbol-p 13 | ;; Bool 14 | :oclcl-bool-p 15 | ;; Int 16 | :oclcl-int-p 17 | ;; Float 18 | :oclcl-float-p 19 | ;; Double 20 | :oclcl-double-p 21 | ;; String 22 | :oclcl-string-p 23 | ;; Float3 24 | :float3 25 | :make-float3 26 | :float3-x 27 | :float3-y 28 | :float3-z 29 | :float3-p 30 | :float3-= 31 | ;; Float4 32 | :float4 33 | :make-float4 34 | :float4-x 35 | :float4-y 36 | :float4-z 37 | :float4-w 38 | :float4-p 39 | :float4-= 40 | ;; Double3 41 | :double3 42 | :make-double3 43 | :double3-x 44 | :double3-y 45 | :double3-z 46 | :double3-p 47 | :double3-= 48 | ;; Double4 49 | :double4 50 | :make-double4 51 | :double4-x 52 | :double4-y 53 | :double4-z 54 | :double4-w 55 | :double4-p 56 | :double4-=)) 57 | (in-package :oclcl.lang.data) 58 | 59 | 60 | ;;; 61 | ;;; Symbol 62 | ;;; 63 | 64 | (deftype oclcl-symbol () 65 | `(satisfies oclcl-symbol-p)) 66 | 67 | (defun oclcl-symbol-p (object) 68 | (symbolp object)) 69 | 70 | 71 | ;;; 72 | ;;; Bool 73 | ;;; 74 | 75 | (defun oclcl-bool-p (object) 76 | (typep object 'boolean)) 77 | 78 | 79 | ;;; 80 | ;;; Int 81 | ;;; 82 | 83 | (defun oclcl-int-p (object) 84 | (integerp object)) 85 | 86 | 87 | ;;; 88 | ;;; Float 89 | ;;; 90 | 91 | (defun oclcl-float-p (object) 92 | (typep object 'single-float)) 93 | 94 | 95 | ;;; 96 | ;;; Double 97 | ;;; 98 | 99 | (defun oclcl-double-p (object) 100 | (typep object 'double-float)) 101 | 102 | ;;; String 103 | ;;; 104 | 105 | (defun oclcl-string-p (object) 106 | (stringp object)) 107 | 108 | ;;; 109 | ;;; Float3 110 | ;;; 111 | 112 | (defstruct (float3 (:constructor make-float3 (x y z))) 113 | (x 0.0 :type single-float) 114 | (y 0.0 :type single-float) 115 | (z 0.0 :type single-float)) 116 | 117 | (defun float3-= (a b) 118 | (and (= (float3-x a) (float3-x b)) 119 | (= (float3-y a) (float3-y b)) 120 | (= (float3-z a) (float3-z b)))) 121 | 122 | (cffi:defcstruct (float3 :class float3-c) 123 | (x :float) 124 | (y :float) 125 | (z :float)) 126 | 127 | (defmethod cffi:translate-into-foreign-memory ((value float3) 128 | (type float3-c) 129 | ptr) 130 | (cffi:with-foreign-slots ((x y z) ptr (:struct float3)) 131 | (setf x (float3-x value) 132 | y (float3-y value) 133 | z (float3-z value)))) 134 | 135 | (defmethod cffi:translate-from-foreign (value (type float3-c)) 136 | (cffi:with-foreign-slots ((x y z) value (:struct float3)) 137 | (make-float3 x y z))) 138 | 139 | 140 | ;;; 141 | ;;; Float4 142 | ;;; 143 | 144 | (defstruct (float4 (:constructor make-float4 (x y z w))) 145 | (x 0.0 :type single-float) 146 | (y 0.0 :type single-float) 147 | (z 0.0 :type single-float) 148 | (w 0.0 :type single-float)) 149 | 150 | (defun float4-= (a b) 151 | (and (= (float4-x a) (float4-x b)) 152 | (= (float4-y a) (float4-y b)) 153 | (= (float4-z a) (float4-z b)) 154 | (= (float4-w a) (float4-w b)))) 155 | 156 | (cffi:defcstruct (float4 :class float4-c) 157 | (x :float) 158 | (y :float) 159 | (z :float) 160 | (w :float)) 161 | 162 | (defmethod cffi:translate-into-foreign-memory ((value float4) 163 | (type float4-c) 164 | ptr) 165 | (cffi:with-foreign-slots ((x y z w) ptr (:struct float4)) 166 | (setf x (float4-x value) 167 | y (float4-y value) 168 | z (float4-z value) 169 | w (float4-w value)))) 170 | 171 | (defmethod cffi:translate-from-foreign (value (type float4-c)) 172 | (cffi:with-foreign-slots ((x y z w) value (:struct float4)) 173 | (make-float4 x y z w))) 174 | 175 | 176 | ;;; 177 | ;;; Double3 178 | ;;; 179 | 180 | (defstruct (double3 (:constructor make-double3 (x y z))) 181 | (x 0.0d0 :type double-float) 182 | (y 0.0d0 :type double-float) 183 | (z 0.0d0 :type double-float)) 184 | 185 | (defun double3-= (a b) 186 | (and (= (double3-x a) (double3-x b)) 187 | (= (double3-y a) (double3-y b)) 188 | (= (double3-z a) (double3-z b)))) 189 | 190 | (cffi:defcstruct (double3 :class double3-c) 191 | (x :double) 192 | (y :double) 193 | (z :double)) 194 | 195 | (defmethod cffi:translate-into-foreign-memory ((value double3) 196 | (type double3-c) 197 | ptr) 198 | (cffi:with-foreign-slots ((x y z) ptr (:struct double3)) 199 | (setf x (double3-x value) 200 | y (double3-y value) 201 | z (double3-z value)))) 202 | 203 | (defmethod cffi:translate-from-foreign (value (type double3-c)) 204 | (cffi:with-foreign-slots ((x y z) value (:struct double3)) 205 | (make-double3 x y z))) 206 | 207 | 208 | ;;; 209 | ;;; Double4 210 | ;;; 211 | 212 | (defstruct (double4 (:constructor make-double4 (x y z w))) 213 | (x 0.0d0 :type double-float) 214 | (y 0.0d0 :type double-float) 215 | (z 0.0d0 :type double-float) 216 | (w 0.0d0 :type double-float)) 217 | 218 | (defun double4-= (a b) 219 | (and (= (double4-x a) (double4-x b)) 220 | (= (double4-y a) (double4-y b)) 221 | (= (double4-z a) (double4-z b)) 222 | (= (double4-w a) (double4-w b)))) 223 | 224 | (cffi:defcstruct (double4 :class double4-c) 225 | (x :double) 226 | (y :double) 227 | (z :double) 228 | (w :double)) 229 | 230 | (defmethod cffi:translate-into-foreign-memory ((value double4) 231 | (type double4-c) 232 | ptr) 233 | (cffi:with-foreign-slots ((x y z w) ptr (:struct double4)) 234 | (setf x (double4-x value) 235 | y (double4-y value) 236 | z (double4-z value) 237 | w (double4-w value)))) 238 | 239 | (defmethod cffi:translate-from-foreign (value (type double3-c)) 240 | (cffi:with-foreign-slots ((x y z w) value (:struct double4)) 241 | (make-double4 x y z w))) 242 | -------------------------------------------------------------------------------- /tests/lang/compiler/compile-expression.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.tests.lang.compiler.compile-expression 9 | (:use :cl :rove 10 | :oclcl.tests.utils 11 | :oclcl.lang.syntax 12 | :oclcl.lang.data 13 | :oclcl.lang.type 14 | :oclcl.lang.built-in 15 | :oclcl.lang.environment 16 | :oclcl.lang.compiler.compile-expression) 17 | (:import-from :oclcl.lang.compiler.compile-expression 18 | :compile-macro 19 | :compile-symbol-macro 20 | :compile-literal 21 | :compile-opencl-literal 22 | :compile-reference 23 | :compile-inline-if 24 | :compile-arithmetic 25 | :compile-function 26 | :compile-sizeof)) 27 | (in-package :oclcl.tests.lang.compiler.compile-expression) 28 | 29 | ;;; 30 | ;;; test COMPILE-EXPRESSION function 31 | ;;; 32 | 33 | (deftest compile-expression 34 | (with-empty-env (env) 35 | (is (compile-expression 1 env) "1"))) 36 | 37 | 38 | ;;; 39 | ;;; test COMPILE-MACRO function 40 | ;;; 41 | 42 | (deftest compile-macro 43 | (with-empty-env (env) 44 | (setf env (function-environment-add-macro 'foo '(x) '(`(+ ,x ,x)) env)) 45 | (is (compile-macro '(foo 1) env) "(1 + 1)" 46 | "basic case 1"))) 47 | 48 | 49 | ;;; 50 | ;;; test COMPILE-SYMBOL-MACRO function 51 | ;;; 52 | 53 | (deftest compile-symbol-macro 54 | (with-empty-env (env) 55 | (setf env (variable-environment-add-symbol-macro 'x 1 env)) 56 | (is (compile-symbol-macro 'x env) "1" 57 | "basic case 1"))) 58 | 59 | 60 | ;;; 61 | ;;; test COMPILE-LITERAL function 62 | ;;; 63 | 64 | (deftest compile-literal 65 | 66 | (is (compile-literal t) "true" 67 | "basic case 1") 68 | 69 | (is (compile-literal nil) "false" 70 | "basic case 2") 71 | 72 | (is (compile-literal 1) "1" 73 | "basic case 3") 74 | 75 | (is (compile-literal 1.0f0) "1.0f" 76 | "basic case 4") 77 | 78 | (is (compile-literal 1.0d0) "1.0" 79 | "basic case 5") 80 | 81 | (is (compile-literal "literal") "\"literal\"" 82 | "string literal")) 83 | 84 | ;;; test COMPILE-OPENCL-LITERAL function 85 | 86 | (deftest compile-opencl-literal 87 | (is (compile-opencl-literal :clk-local-mem-fence) 88 | "CLK_LOCAL_MEM_FENCE" 89 | "CLK_LOCAL_MEM_FENCE") 90 | (is (compile-opencl-literal :clk-global-mem-fence) 91 | "CLK_GLOBAL_MEM_FENCE" 92 | "CLK_GLOBAL_MEM_FENCE")) 93 | 94 | ;;; 95 | ;;; test COMPILE-REFERENCE funcion 96 | ;;; 97 | 98 | (deftest compile-reference-variable 99 | (let* ((env (empty-environment)) 100 | (env (variable-environment-add-variable 'x 'int env)) 101 | (env (variable-environment-add-symbol-macro 'y 'y-expansion env)) 102 | (env (variable-environment-add-variable 'y-expansion 'float env)) 103 | (env (variable-environment-add-memory 'z 'int 1 env))) 104 | (is (compile-reference 'x env) "x" 105 | "basic case 1") 106 | (is (compile-reference 'z env) 107 | "oclcl_tests_lang_compiler_compile_expression_z" 108 | "basic case 2") 109 | (ok (signals (compile-reference 'y env) 'simple-error) 110 | "FORM which is a variable not found.") 111 | (ok (signals (compile-reference 'a env) 'simple-error) 112 | "FORM which is a variable not found."))) 113 | 114 | (deftest compile-reference-structure 115 | (let* ((env (empty-environment)) 116 | (env (variable-environment-add-variable 'x 'float3 env))) 117 | (is (compile-reference '(float3-x x) env) "x.x" 118 | "basic case 1") 119 | (is (compile-reference '(float3-y x) env) "x.y" 120 | "basic case 2") 121 | (ok (signals (compile-reference '(float4-x x) env) 122 | 'simple-error)))) 123 | 124 | 125 | (deftest compile-reference-array 126 | (let* ((env (empty-environment)) 127 | (env (variable-environment-add-variable 'x 'int* env)) 128 | (env (variable-environment-add-variable 'i 'int env))) 129 | (is (compile-reference '(aref x i) env) "x[i]" 130 | "basic case 1"))) 131 | 132 | 133 | ;;; 134 | ;;; test COMPILE-INLINE-IF function 135 | ;;; 136 | 137 | (deftest compile-inline-if 138 | (with-empty-env (env) 139 | (is (compile-inline-if '(if (= 1 1) 1 2) env) 140 | "((1 == 1) ? 1 : 2)" 141 | "basic case 1"))) 142 | 143 | 144 | ;;; 145 | ;;; test COMPILE-ARITHMETIC function 146 | ;;; 147 | 148 | (deftest compile-arithmetic 149 | (with-empty-env (env) 150 | (is (compile-arithmetic '(+ 1 1 1) env) "((1 + 1) + 1)" 151 | "add integer") 152 | (is (compile-arithmetic '(- 1 1 1) env) "((1 - 1) - 1)" 153 | "sub integer") 154 | (is (compile-arithmetic '(* 1 1 1) env) "((1 * 1) * 1)" 155 | "mul integer") 156 | (is (compile-arithmetic '(/ 1 1 1) env) "((1 / 1) / 1)" 157 | "div integer") 158 | (is (compile-arithmetic '(mod 1 1 1) env) "((1 % 1) % 1)" 159 | "mod integer") 160 | (is (compile-arithmetic '(+ 1 1 (- 1 1)) env) "((1 + 1) + (1 - 1))" 161 | "mix integer") 162 | (is (compile-arithmetic '(+ 1.0f0 2.0f0 3.0f0 4.0f0) env) 163 | "(((1.0f + 2.0f) + 3.0f) + 4.0f)" 164 | "add float"))) 165 | 166 | 167 | ;;; 168 | ;;; test COMPILE-FUNCTION function 169 | ;;; 170 | 171 | (deftest compile-function 172 | (let* ((env (empty-environment)) 173 | (env (function-environment-add-function 'foo 'int '(int int) env))) 174 | (is (compile-function '(foo 1 1) env) 175 | "oclcl_tests_lang_compiler_compile_expression_foo(1, 1)" 176 | "basic case 1") 177 | (ok (signals (compile-function '(foo 1 1 1) env) 'simple-error))) 178 | 179 | (with-empty-env (env) 180 | (is (compile-function '(+ 1 1) env) "(1 + 1)" 181 | "basic case 2") 182 | (is (compile-function '(- 1) env) "-(1)" 183 | "basic case 3") 184 | (is (compile-function '(+ (float3 1.0f0 1.0f0 1.0f0) (float3 2.0f0 2.0f0 2.0f0)) 185 | env) 186 | "((float3)(1.0f, 1.0f, 1.0f) + (float3)(2.0f, 2.0f, 2.0f))" 187 | "float3 constructor") 188 | (is (compile-function '(barrier :clk-local-mem-fence) env) 189 | "barrier(CLK_LOCAL_MEM_FENCE)" 190 | "barrier"))) 191 | 192 | ;;; 193 | ;;; test COMPILE-SIZEOF function 194 | ;;; 195 | 196 | (deftest compile-sizoef 197 | (with-empty-env (env) 198 | (setf env (variable-environment-add-variable 'alfa 'int env)) 199 | (is (compile-sizeof '(sizeof alfa) env) "sizeof(alfa)" "sizeof variable") 200 | (is (compile-sizeof '(sizeof float) env) "sizeof(float)" "sizeof type"))) -------------------------------------------------------------------------------- /tests/lang/syntax.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.tests.lang.syntax 9 | (:use :cl :rove 10 | :oclcl.tests.utils 11 | :oclcl.lang.data 12 | :oclcl.lang.syntax)) 13 | (in-package :oclcl.tests.lang.syntax) 14 | 15 | ;;; 16 | ;;; test Symbol macro 17 | ;;; 18 | 19 | (deftest symbol-macro 20 | (is (symbol-macro-p 'alfa) t)) 21 | 22 | ;;; 23 | ;;; test Macro 24 | ;;; 25 | 26 | (deftest macro 27 | 28 | (is (macro-p '(+ 1 1)) t 29 | "basic case 1") 30 | (is (macro-p '(foo 1)) t 31 | "basic case 2") 32 | (is (macro-p 'bar) nil 33 | "basic case 3") 34 | 35 | (is (macro-operator '(+ 1 1)) '+ 36 | "basic case 4") 37 | 38 | (is (macro-operands '(+ 1 1)) '(1 1) 39 | "basic case 5")) 40 | 41 | 42 | ;;; 43 | ;;; test Literal 44 | ;;; 45 | 46 | (deftest literal 47 | 48 | (is (literal-p 't) t 49 | "basic case 1") 50 | (is (literal-p 'nil) t 51 | "basic case 2") 52 | (is (literal-p 1) t 53 | "basic case 3") 54 | (is (literal-p 1.0) t 55 | "basic case 4") 56 | (is (literal-p 1.0d0) t 57 | "basic case 5") 58 | (is (literal-p "literal") t 59 | "string literal")) 60 | 61 | ;;; test OpenCL literal 62 | ;;; 63 | 64 | (deftest opencl-literal 65 | (is (opencl-literal-p :clk-global-mem-fence) t)) 66 | 67 | 68 | ;;; 69 | ;;; test Reference 70 | ;;; 71 | 72 | (deftest reference 73 | 74 | (is (reference-p 'x) t 75 | "basic case 1") 76 | (is (reference-p '(float3-x x)) t 77 | "basic case 2") 78 | (is (reference-p '(float4-w x)) t 79 | "basic case 3") 80 | (is (reference-p '(aref x)) t 81 | "basic case 4") 82 | (is (reference-p '(aref x i)) t 83 | "basic case 5") 84 | (is (reference-p '(aref x i i)) t 85 | "basic case 6")) 86 | 87 | 88 | ;;; 89 | ;;; test Inline-if 90 | ;;; 91 | 92 | (deftest inline-if 93 | 94 | (is (inline-if-p '(if)) t 95 | "basic case 1") 96 | (is (inline-if-p '(if t)) t 97 | "basic case 2") 98 | (is (inline-if-p '(if t 2)) t 99 | "basic case 3") 100 | (is (inline-if-p '(if t 2 3)) t 101 | "basic case 4") 102 | (is (inline-if-p '(if t 2 3 4)) t 103 | "basic case 5")) 104 | 105 | 106 | ;;; 107 | ;;; test Arithmetic 108 | ;;; 109 | 110 | (deftest arithmetic 111 | (is (arithmetic-p '(+ 1)) t) 112 | (is (arithmetic-operator '(+ 1)) '+) 113 | (is (arithmetic-operands '(* 1 2)) '(1 2))) 114 | 115 | ;;; 116 | ;;; test Function application 117 | ;;; 118 | 119 | (deftest function-application 120 | 121 | (is (function-p 'a) nil 122 | "basic case 1") 123 | (is (function-p '()) nil 124 | "basic case 2") 125 | (is (function-p '1) nil 126 | "basic case 3") 127 | (is (function-p '(foo)) t 128 | "basic case 4") 129 | (is (function-p '(+ 1 1)) t 130 | "basic case 5") 131 | (is (function-p '(foo 1 1)) t 132 | "basic case 6") 133 | 134 | (ok (signals (function-operator 'a) 'simple-error) 135 | "FORM which is an invalid function application.") 136 | (is (function-operator '(foo)) 'foo 137 | "basic case 7") 138 | (is (function-operator '(+ 1 1)) '+ 139 | "basic case 8") 140 | (is (function-operator '(foo 1 1)) 'foo 141 | "basic case 9") 142 | 143 | (ok (signals (function-operands 'a) 'simple-error) 144 | "FORM which is an invalid function application.") 145 | (is (function-operands '(foo)) '() 146 | "basic case 10") 147 | (is (function-operands '(+ 1 1)) '(1 1) 148 | "basic case 11") 149 | (is (function-operands '(foo 1 1)) '(1 1) 150 | "basic case 12")) 151 | 152 | 153 | ;;; 154 | ;;; test If statement 155 | ;;; 156 | 157 | (deftest if-statement 158 | 159 | (is (if-else-statement '(if (= 1 1) (return 1))) nil 160 | "basic case 1")) 161 | 162 | 163 | ;;; 164 | ;;; test Let statement 165 | ;;; 166 | 167 | (deftest let-statement 168 | (is (let-statements '(let ((alfa 0)))) nil) 169 | (is (let-statements '(let ((alfa 0)) alfa bravo)) '(alfa bravo))) 170 | 171 | ;;; 172 | ;;; test Symbol-macrolet statement 173 | ;;; 174 | 175 | (deftest symbol-macrolet-statement 176 | 177 | (ok (symbol-macrolet-p '(symbol-macrolet ((x 'expanded-x)) 178 | (return))) 179 | "basic case 1") 180 | (ok (symbol-macrolet-p '(symbol-macrolet ((x 'expanded-x)) 181 | (do-something) 182 | (return))) 183 | "basic case 2") 184 | (ok (symbol-macrolet-p '(symbol-macrolet ((x 'expanded-x)))) 185 | "basic case 3")) 186 | 187 | 188 | ;;; 189 | ;;; test Do statement 190 | ;;; 191 | 192 | (deftest do-statement 193 | 194 | (let ((code '(do ((a 0 (+ a 1)) 195 | (b 0 (+ b 1))) 196 | ((> a 15)) 197 | (return)))) 198 | (ok (do-p code) 199 | "basic case 1") 200 | (is (do-bindings code) '((a 0 (+ a 1)) 201 | (b 0 (+ b 1))) 202 | "basic case 2") 203 | (is (do-end-test code) '(> a 15) 204 | "basic case 3") 205 | (is (do-statements code) '((return)) 206 | "basic case 4"))) 207 | 208 | (deftest do-statement-binding 209 | 210 | (let ((binding '(a 0 (+ a 1)))) 211 | (ok (do-binding-p binding) 212 | "basic case 1") 213 | (is (do-binding-var binding) 'a 214 | "basic case 2") 215 | (is (do-binding-init binding) 0 216 | "basic case 3") 217 | (is (do-binding-step binding) '(+ a 1) 218 | "basic case 4"))) 219 | 220 | 221 | ;;; 222 | ;;; test With-local-memory statement 223 | ;;; 224 | 225 | (deftest with-local-memory-p 226 | 227 | (ok (with-local-memory-p '(with-local-memory ((a float 16)) 228 | (return))) 229 | "basic case 1") 230 | (ok (with-local-memory-p '(with-local-memory () 231 | (return))) 232 | "basic case 2") 233 | (ok (with-local-memory-p '(with-local-memory ())) 234 | "basic case 3") 235 | (ok (with-local-memory-p '(with-local-memory)) 236 | "basic case 4")) 237 | 238 | 239 | (deftest with-local-memory-spec-p 240 | 241 | (ok (with-local-memory-spec-p '(a float 16)) 242 | "basic case 1") 243 | (ok (with-local-memory-spec-p '(a float (+ 16 2))) 244 | "basic case 2")) 245 | 246 | 247 | ;;; 248 | ;;; test Set statement 249 | ;;; 250 | 251 | (deftest set-statement 252 | (ok (set-p '(set x 1)) 253 | "basic case 1") 254 | (ok (set-p '(set (aref x i) 1)) 255 | "basic case 2")) 256 | 257 | 258 | 259 | ;;; 260 | ;;; test Progn statement 261 | ;;; 262 | 263 | (deftest progn-statements 264 | (is (progn-statements '(progn alfa bravo)) '(alfa bravo))) 265 | 266 | ;;; 267 | ;;; test Return expr 268 | ;;; 269 | 270 | (deftest return-expr 271 | (is (return-expr '(return alfa)) 'alfa)) 272 | 273 | ;;; 274 | ;;; test Argument 275 | ;;; 276 | 277 | -------------------------------------------------------------------------------- /examples/diffuse0-oclapi.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2016 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl-examples.diffuse0-oclapi 9 | (:use :cl 10 | :cffi 11 | :oclcl 12 | :cl-oclapi) 13 | (:export :main)) 14 | (in-package :oclcl-examples.diffuse0-oclapi) 15 | 16 | (define-program :diffuse0-oclapi 17 | (:use :oclcl)) 18 | (in-program :diffuse0-oclapi) 19 | 20 | ;;; image output functions 21 | 22 | (declaim (inline index)) 23 | (defun index (nx jx jy) 24 | (the fixnum (+ (the fixnum (* nx jy)) jx))) 25 | 26 | (defun image-value (f i j nx fmax fmin) 27 | (let ((fc (mem-aref f :float (index nx i j)))) 28 | (truncate (* 256.0 29 | (/ (- fc fmin) (- fmax fmin)))))) 30 | 31 | (defun file-name (dir i nout) 32 | (let ((n (truncate (/ i nout)))) 33 | (concatenate 'string dir (format nil "~4,'0D.pgm" n)))) 34 | 35 | (defun output-pnm (dir i nout nx ny f) 36 | (let ((image (make-instance 'imago:grayscale-image 37 | :width nx :height ny))) 38 | (dotimes (i nx) 39 | (dotimes (j ny) 40 | (setf (imago:image-pixel image i j) (image-value f i j nx 1.0 0.0)))) 41 | (imago:write-pnm image (file-name dir i nout) :ASCII)) 42 | (values)) 43 | 44 | 45 | ;;; print functions 46 | 47 | (defun print-elapsed-time (elapsed-time) 48 | (let ((time (* elapsed-time 1.0e-3))) 49 | (format t "Elapsed Time = ~,3F [sec]~%" time))) 50 | 51 | (defun print-performance (flo elapsed-time) 52 | (let ((time (* elapsed-time 1.0e-3))) 53 | (format t "Performance = ~,2F [MFlops]~%" (* (/ flo time) 1.0e-6)))) 54 | 55 | (defun print-time (cnt time) 56 | (format t "time(~A) = ~,5F~%" cnt time)) 57 | 58 | 59 | ;;; main functions 60 | 61 | (defkernel diffusion2d (void ((f float*) (fn float*) 62 | (nx int) (ny int) 63 | (c0 float) (c1 float) (c2 float))) 64 | (let* ((jy (to-int (get-global-id 1))) 65 | (jx (to-int (get-global-id 0))) 66 | (j (+ (* nx jy) jx))) 67 | (let ((fcc (aref f j)) 68 | (fcw 0.0) 69 | (fce 0.0) 70 | (fcs 0.0) 71 | (fcn 0.0)) 72 | (if (= jx 0) 73 | (set fcw fcc) 74 | (set fcw (aref f (- j 1)))) 75 | (if (= jx (- nx 1)) 76 | (set fce fcc) 77 | (set fce (aref f (+ j 1)))) 78 | (if (= jy 0) 79 | (set fcs fcc) 80 | (set fcs (aref f (- j nx)))) 81 | (if (= jy (- ny 1)) 82 | (set fcn fcc) 83 | (set fcn (aref f (+ j nx)))) 84 | (set (aref fn j) (+ (* c0 (+ fce fcw)) 85 | (* c1 (+ fcn fcs)) 86 | (* c2 fcc)))))) 87 | 88 | (defun initialize-device-memory (nx ny dx dy command-queue host-memory device-memory) 89 | (let ((alpha 30.0)) 90 | (dotimes (jy ny) 91 | (dotimes (jx nx) 92 | (let ((j (index nx jx jy)) 93 | (x (- (* dx (+ (float jx 1.0) 0.5)) 0.5)) 94 | (y (- (* dy (+ (float jy 1.0) 0.5)) 0.5))) 95 | (setf (mem-aref host-memory :float j) 96 | (exp (* (- alpha) 97 | (+ (* x x) (* y y))))))))) 98 | 99 | (enqueue-write-buffer command-queue 100 | device-memory 101 | +cl-true+ 102 | 0 103 | (* (foreign-type-size :float) 104 | (* nx ny)) 105 | host-memory) 106 | (finish command-queue)) 107 | 108 | (defun diffusion2d (nx ny command-queue kernel f fn kappa dt dx dy) 109 | (let* ((c0 (* kappa (/ dt (* dx dx)))) 110 | (c1 (* kappa (/ dt (* dy dy)))) 111 | (c2 (- 1.0 (* 2.0 (+ c0 c1))))) 112 | (with-work-size (global-work-size nx ny) 113 | (with-pointers ((f-pointer f) 114 | (fn-pointer fn)) 115 | (with-foreign-objects ((%nx 'cl-int) 116 | (%ny 'cl-int) 117 | (%c0 'cl-float) 118 | (%c1 'cl-float) 119 | (%c2 'cl-float)) 120 | (setf (mem-aref %nx 'cl-int) nx) 121 | (setf (mem-aref %ny 'cl-int) ny) 122 | (setf (mem-aref %c0 'cl-float) c0) 123 | (setf (mem-aref %c1 'cl-float) c1) 124 | (setf (mem-aref %c2 'cl-float) c2) 125 | (set-kernel-arg kernel 0 8 f-pointer) 126 | (set-kernel-arg kernel 1 8 fn-pointer) 127 | (set-kernel-arg kernel 2 4 %nx) 128 | (set-kernel-arg kernel 3 4 %ny) 129 | (set-kernel-arg kernel 4 4 %c0) 130 | (set-kernel-arg kernel 5 4 %c1) 131 | (set-kernel-arg kernel 6 4 %c2) 132 | (enqueue-ndrange-kernel command-queue 133 | kernel 134 | 2 135 | global-work-size 136 | (null-pointer)) 137 | (finish command-queue)))) 138 | (* nx ny 7.0))) 139 | 140 | (defmacro swap (a b) 141 | `(rotatef ,a ,b)) 142 | 143 | (defun main () 144 | (let* ((nx 256) (ny 256) 145 | (Lx 1.0) (Ly 1.0) 146 | (dx (/ Lx (float nx 1.0))) 147 | (dy (/ Ly (float ny 1.0))) 148 | (kappa 0.1) 149 | (dt (/ (* 0.2 (min (* dx dx) (* dy dy))) kappa)) 150 | (time 0) 151 | (flo 0) 152 | (elements (* nx ny)) 153 | (float-size (foreign-type-size :float)) 154 | (data-bytes (* float-size elements)) 155 | (*program* (find-program :diffuse0-oclapi)) 156 | (c-source-code (compile-program *program*))) 157 | (print c-source-code) 158 | (with-platform-id (platform) 159 | (with-device-ids (devices num-devices platform) 160 | (with-context (context (null-pointer) 1 devices) 161 | (with-program-with-source (program context 1 c-source-code) 162 | (build-program program 1 devices) 163 | (with-foreign-objects ((a-host :float elements) 164 | (b-host :float elements)) 165 | (with-buffers ((a-device context +cl-mem-read-only+ data-bytes) 166 | (b-device context +cl-mem-write-only+ data-bytes)) 167 | (let ((device (mem-aref devices 'cl-device-id))) 168 | (with-command-queue (command-queue context device 0) 169 | (initialize-device-memory nx ny dx dy command-queue a-host a-device) 170 | (with-work-size (global-work-size elements) 171 | (with-kernel (kernel program (program-function-c-name *program* 'diffusion2d)) 172 | (dotimes (i 20000) 173 | (when (= (mod i 100) 0) 174 | (print-time i time)) 175 | (incf flo (diffusion2d nx ny command-queue kernel a-device b-device kappa dt dx dy)) 176 | (incf time dt) 177 | (swap a-device b-device)))))))))))))) 178 | -------------------------------------------------------------------------------- /src/lang/compiler/type-of-expression.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.lang.compiler.type-of-expression 9 | (:use :cl 10 | :oclcl.lang.type 11 | :oclcl.lang.syntax 12 | :oclcl.lang.environment 13 | :oclcl.lang.built-in) 14 | (:import-from #:alexandria 15 | #:rcurry) 16 | (:export :type-of-expression)) 17 | (in-package :oclcl.lang.compiler.type-of-expression) 18 | 19 | 20 | ;;; 21 | ;;; Type of expression 22 | ;;; 23 | 24 | (defun type-of-expression (form env) 25 | (cond 26 | ((%macro-p form env) (type-of-macro form env)) 27 | ((%symbol-macro-p form env) 28 | (type-of-symbol-macro form env)) 29 | ((literal-p form) (type-of-literal form)) 30 | ((opencl-literal-p form) (type-of-opencl-literal form)) 31 | ((reference-p form) (type-of-reference form env)) 32 | ((inline-if-p form) (type-of-inline-if form env)) 33 | ((sizeof-p form) (type-of-sizeof form)) 34 | ((arithmetic-p form) (type-of-arithmetic form env)) 35 | ((function-p form) (type-of-function form env)) 36 | (t (error "The value ~S is an invalid expression." form)))) 37 | 38 | 39 | ;;; 40 | ;;; Macro 41 | ;;; 42 | 43 | (defun %macro-p (form env) 44 | (and (macro-p form) 45 | (function-environment-macro-exists-p env 46 | (macro-operator form)))) 47 | 48 | (defun type-of-macro (form env) 49 | (let ((name (macro-operator form)) 50 | (arguments (macro-operands form))) 51 | (let ((expander (function-environment-macro-expander env name))) 52 | (let ((form1 (funcall expander arguments))) 53 | (type-of-expression form1 env))))) 54 | 55 | 56 | ;;; 57 | ;;; Symbol macro 58 | ;;; 59 | 60 | (defun %symbol-macro-p (form env) 61 | (and (symbolp form) 62 | (variable-environment-symbol-macro-exists-p env form))) 63 | 64 | (defun type-of-symbol-macro (form env) 65 | (let ((form1 (variable-environment-symbol-macro-expansion env form))) 66 | (type-of-expression form1 env))) 67 | 68 | 69 | ;;; 70 | ;;; Literal 71 | ;;; 72 | 73 | (defun type-of-literal (form) 74 | (cond 75 | ((bool-literal-p form) 'bool) 76 | ((int-literal-p form) 'int) 77 | ((float-literal-p form) 'float) 78 | ((double-literal-p form) 'double) 79 | ((string-literal-p form) 'string) 80 | (t (error "The value ~S is an invalid expression." form)))) 81 | 82 | (defun type-of-opencl-literal (form) 83 | (cond 84 | ((cl-mem-fence-flags-literal-p form) 'cl-mem-fence-flags) 85 | (t (error "The value ~s is an invalid expression." form)))) 86 | 87 | ;;; 88 | ;;; Reference 89 | ;;; 90 | 91 | (defun type-of-reference (form env) 92 | (cond 93 | ((variable-reference-p form) 94 | (type-of-variable-reference form env)) 95 | ((structure-reference-p form) 96 | (type-of-structure-reference form env)) 97 | ((array-reference-p form) 98 | (type-of-array-reference form env)) 99 | (t (error "The value ~S is an invalid expression." form)))) 100 | 101 | 102 | ;;; 103 | ;;; Reference - Variable 104 | ;;; 105 | 106 | (defun type-of-variable-reference (form env) 107 | (cond 108 | ((variable-environment-variable-exists-p env form) 109 | (variable-environment-variable-type env form)) 110 | ((variable-environment-memory-exists-p env form) 111 | (variable-environment-memory-type env form)) 112 | (t 113 | (error "The variable ~S not found." form)))) 114 | 115 | ;;; 116 | ;;; Reference - Structure 117 | ;;; 118 | 119 | (defun type-of-structure-reference (form env) 120 | (let ((accessor (structure-reference-accessor form)) 121 | (expr (structure-reference-expr form))) 122 | ;; check if the expression part of structure reference has the 123 | ;; same type as accessor's structure 124 | (let ((structure (structure-from-accessor accessor)) 125 | (expr-type (type-of-expression expr env))) 126 | (unless (eq structure expr-type) 127 | (error "The structure reference ~S is invalid." form))) 128 | (structure-accessor-return-type accessor))) 129 | 130 | 131 | ;;; 132 | ;;; Reference - Array 133 | ;;; 134 | 135 | (defun type-of-array-reference (form env) 136 | (let ((expr (array-reference-expr form)) 137 | (indices (array-reference-indices form))) 138 | (let ((expr-type (type-of-expression expr env))) 139 | ;; check if the expression part of array reference has the same 140 | ;; dimension as the array reference 141 | (unless (= (array-type-dimension expr-type) (length indices)) 142 | (error "The dimension of array reference ~S is invalid." form)) 143 | (array-type-base expr-type)))) 144 | 145 | 146 | ;;; 147 | ;;; Inline-if 148 | ;;; 149 | 150 | (defun type-of-inline-if (form env) 151 | (let ((test-expr (inline-if-test-expression form)) 152 | (then-expr (inline-if-then-expression form)) 153 | (else-expr (inline-if-else-expression form))) 154 | ;; check if the test part of inline-if expression has bool type 155 | (let ((test-type (type-of-expression test-expr env))) 156 | (unless (eq test-type 'bool) 157 | (error "The type of expression ~S is invalid." form))) 158 | (let ((then-type (type-of-expression then-expr env)) 159 | (else-type (type-of-expression else-expr env))) 160 | ;; check if the then part of inline-of expression has the same 161 | ;; type as the else part of it 162 | (unless (eq then-type else-type) 163 | (error "The type of expression ~S is invalid." form)) 164 | then-type))) 165 | 166 | 167 | ;;; 168 | ;;; Arithmetic operations 169 | ;;; 170 | 171 | (defun type-of-arithmetic (form env) 172 | (let ((operator (arithmetic-operator form)) 173 | (operands (arithmetic-operands form))) 174 | (if (<= (length operands) 2) 175 | (type-of-function form env) 176 | (let ((operand-head (car operands)) 177 | (operand-tail (cdr operands))) 178 | (let ((form1 `(,operator ,operand-head 179 | (,operator ,@operand-tail)))) 180 | (type-of-expression form1 env)))))) 181 | 182 | 183 | ;;; 184 | ;;; Function application 185 | ;;; 186 | 187 | (defun type-of-operands (operands env) 188 | (mapcar (rcurry #'type-of-expression env) 189 | operands)) 190 | 191 | (defun type-of-function (form env) 192 | (let ((operator (function-operator form))) 193 | (if (function-environment-function-exists-p env operator) 194 | (type-of-user-defined-function form env) 195 | (type-of-built-in-function form env)))) 196 | 197 | (defun type-of-user-defined-function (form env) 198 | (let ((operator (function-operator form)) 199 | (operands (function-operands form))) 200 | ;; check if the operands have the same types as the operator expect 201 | (let ((expected (function-environment-function-argument-types 202 | env operator)) 203 | (actual (type-of-operands operands env))) 204 | (unless (equal expected actual) 205 | (error "The function application ~S is invalid." form))) 206 | (function-environment-function-return-type env operator))) 207 | 208 | (defun type-of-built-in-function (form env) 209 | (let ((operator (function-operator form)) 210 | (operands (function-operands form))) 211 | (let ((argument-types (type-of-operands operands env))) 212 | (built-in-function-return-type operator argument-types)))) 213 | 214 | ;;; 215 | ;;; Sizeof 216 | ;;; 217 | 218 | (defun type-of-sizeof(form env) 219 | 'size-t) -------------------------------------------------------------------------------- /examples/diffuse1.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2016 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl-examples.diffuse1 9 | (:use :cl 10 | :cffi 11 | :oclcl 12 | :eazy-opencl.host) 13 | (:export :main)) 14 | (in-package :oclcl-examples.diffuse1) 15 | 16 | (define-program :diffuse1-eazyopencl 17 | (:use :oclcl)) 18 | (in-program :diffuse1-eazyopencl) 19 | 20 | ;;; image output functions 21 | 22 | (declaim (inline index)) 23 | (defun index (nx jx jy) 24 | (the fixnum (+ (the fixnum (* nx jy)) jx))) 25 | 26 | (defun image-value (f i j nx fmax fmin) 27 | (let ((fc (memory-block-aref f (index nx i j)))) 28 | (truncate (* 256.0 29 | (/ (- fc fmin) (- fmax fmin)))))) 30 | 31 | (defun file-name (dir i nout) 32 | (let ((n (truncate (/ i nout)))) 33 | (concatenate 'string dir (format nil "~4,'0D.pgm" n)))) 34 | 35 | (defun output-pnm (dir i nout nx ny f) 36 | (let ((image (make-instance 'imago:grayscale-image 37 | :width nx :height ny))) 38 | (dotimes (i nx) 39 | (dotimes (j ny) 40 | (setf (imago:image-pixel image i j) (image-value f i j nx 1.0 0.0)))) 41 | (imago:write-pnm image (file-name dir i nout) :ASCII)) 42 | (values)) 43 | 44 | 45 | ;;; print functions 46 | 47 | (defun print-elapsed-time (elapsed-time) 48 | (let ((time (* elapsed-time 1.0e-3))) 49 | (format t "Elapsed Time = ~,3F [sec]~%" time))) 50 | 51 | (defun print-performance (flo elapsed-time) 52 | (let ((time (* elapsed-time 1.0e-3))) 53 | (format t "Performance = ~,2F [MFlops]~%" (* (/ flo time) 1.0e-6)))) 54 | 55 | (defun print-time (cnt time) 56 | (format t "time(~A) = ~,5F~%" cnt time)) 57 | 58 | 59 | ;;; main functions 60 | 61 | (defkernel diffusion2d (void ((f float*) (fn float*) 62 | (nx int) (ny int) 63 | (c0 float) (c1 float) (c2 float))) 64 | (let ((local-id-x (to-int (get-local-id 0))) 65 | (local-id-y (to-int (get-local-id 1))) 66 | (global-id-x (to-int (get-global-id 0))) 67 | (global-id-y (to-int (get-global-id 1))) 68 | (local-size-x (to-int (get-local-size 0))) 69 | (local-size-y (to-int (get-local-size 1))) 70 | (group-id-x (to-int (get-group-id 0))) 71 | (group-id-y (to-int (get-group-id 1))) 72 | (num-groups-x (to-int (get-num-groups 0))) 73 | (num-groups-y (to-int (get-num-groups 1)))) 74 | (let* ((jx (+ local-id-x 1)) 75 | (jy (+ local-id-y 1)) 76 | (j (+ (* nx global-id-y) global-id-x)) 77 | (fcc (aref f j))) 78 | (with-local-memory ((fs float (+ 16 2) (+ 16 2))) 79 | (set (aref fs jy jx) fcc) 80 | (if (= local-id-x 0) 81 | (if (= group-id-x 0) 82 | (set (aref fs jy 0) fcc) 83 | (set (aref fs jy 0) (aref f (- j 1))))) 84 | (if (= local-id-x (- local-size-x 1)) 85 | (if (= group-id-x (- num-groups-x 1)) 86 | (set (aref fs jy (+ local-size-x 1)) fcc) 87 | (set (aref fs jy (+ local-size-x 1)) (aref f (+ j 1))))) 88 | (if (= local-id-y 0) 89 | (if (= group-id-y 0) 90 | (set (aref fs 0 jx) fcc) 91 | (set (aref fs 0 jx) (aref f (- j nx))))) 92 | (if (= local-id-y (- local-size-y 1)) 93 | (if (= group-id-y (- num-groups-y 1)) 94 | (set (aref fs (+ local-size-y 1) jx) fcc) 95 | (set (aref fs (+ local-size-y 1) jx) (aref f (+ j nx))))) 96 | (barrier :clk-local-mem-fence) 97 | (printf "%f" (aref fs 0 0)) 98 | (set (aref fn j) (+ (* c0 (+ (aref fs jy (+ jx 1)) 99 | (aref fs jy (- jx 1)))) 100 | (* c1 (+ (aref fs (+ jy 1) jx) 101 | (aref fs (- jy 1) jx))) 102 | (* c2 (aref fs jy jx)))))))) 103 | 104 | (defun initialize-device-memory (nx ny dx dy command-queue host-memory device-memory) 105 | (let ((alpha 30.0)) 106 | (dotimes (jy ny) 107 | (dotimes (jx nx) 108 | (let ((j (index nx jx jy)) 109 | (x (- (* dx (+ (float jx 1.0) 0.5)) 0.5)) 110 | (y (- (* dy (+ (float jy 1.0) 0.5)) 0.5))) 111 | (setf (mem-aref host-memory :float j) 112 | (exp (* (- alpha) 113 | (+ (* x x) (* y y))))))))) 114 | (%ocl:enqueue-write-buffer command-queue 115 | device-memory 116 | %ocl:true 117 | 0 118 | (* (foreign-type-size :float) 119 | (* nx ny)) 120 | host-memory 121 | 0 122 | (null-pointer) 123 | (null-pointer))) 124 | 125 | (defun diffusion2d (nx ny command-queue kernel f fn kappa dt dx dy) 126 | (let* ((c0 (* kappa (/ dt (* dx dx)))) 127 | (c1 (* kappa (/ dt (* dy dy)))) 128 | (c2 (- 1.0 (* 2.0 (+ c0 c1))))) 129 | (%ocl/h::with-foreign-array (global-work-size '%ocl:size-t (list nx ny)) 130 | (set-kernel-arg kernel 0 f '%ocl:mem) 131 | (set-kernel-arg kernel 1 fn '%ocl:mem) 132 | (set-kernel-arg kernel 2 nx :int) 133 | (set-kernel-arg kernel 3 ny :int) 134 | (set-kernel-arg kernel 4 c0 :float) 135 | (set-kernel-arg kernel 5 c1 :float) 136 | (set-kernel-arg kernel 6 c2 :float) 137 | (%ocl:enqueue-nd-range-kernel command-queue 138 | kernel 139 | 2 140 | (null-pointer) 141 | global-work-size 142 | (null-pointer) 143 | 0 144 | (null-pointer) 145 | (null-pointer))) 146 | (%ocl:finish command-queue) 147 | (* nx ny 7.0))) 148 | 149 | (defmacro swap (a b) 150 | `(rotatef ,a ,b)) 151 | 152 | (defun main () 153 | (let* ((nx 256) (ny 256) 154 | (Lx 1.0) (Ly 1.0) 155 | (dx (/ Lx (float nx 1.0))) 156 | (dy (/ Ly (float ny 1.0))) 157 | (kappa 0.1) 158 | (dt (/ (* 0.2 (min (* dx dx) (* dy dy))) kappa)) 159 | (time 0) 160 | (flo 0) 161 | (platform-id (car (get-platform-ids))) 162 | (devices (get-device-ids platform-id :device-type-default)) 163 | (context (create-context devices)) 164 | (command-queue (create-command-queue context (car devices) 0)) 165 | (*program* (find-program :diffuse1-eazyopencl)) 166 | (c-source-code (compile-program *program*)) 167 | (program (create-program-with-source context c-source-code)) 168 | (elements (* nx ny)) 169 | (float-size (foreign-type-size :float)) 170 | (data-bytes (* float-size elements))) 171 | (with-foreign-objects ((a-host :float elements)) 172 | (let* ((a-device (create-buffer context :mem-read-only data-bytes)) 173 | (b-device (create-buffer context :mem-read-only data-bytes))) 174 | (initialize-device-memory nx ny dx dy command-queue a-host a-device) 175 | (build-program program :devices devices) 176 | (let ((kernel (create-kernel program "oclcl_examples_diffuse1_diffusion2d"))) 177 | (dotimes (i 20000) 178 | (when (= (mod i 100) 0) 179 | (print-time i time)) 180 | (incf flo (diffusion2d nx ny command-queue kernel a-device b-device kappa dt dx dy)) 181 | (incf time dt) 182 | (swap a-device b-device))))))) 183 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # oclcl 2 | 3 | [![CircleCI Status](https://circleci.com/gh/gos-k/oclcl.svg?style=shield)](https://circleci.com/gh/gos-k/oclcl) 4 | [![TravisCI Status](https://travis-ci.org/gos-k/oclcl.svg?branch=master)](https://travis-ci.org/gos-k/oclcl) 5 | [![Quicklisp](http://quickdocs.org/badge/oclcl.svg)](http://quickdocs.org/oclcl/) 6 | 7 | oclcl is a library to use [OpenCL](https://www.khronos.org/opencl/) in Common Lisp programs. 8 | It provides the kernel description language with which users can define OpenCL kernel functions in S-expression. 9 | The kernel description language also provides facilities to define kernel macros and kernel symbol macros in addition to kernel functions. 10 | oclcl's kernel macro and kernel symbol macro offer powerful abstraction that OpenCL C itself does not have and provide enormous advantage in resource-limited GPU programming. 11 | 12 | ## Installation 13 | 14 | oclcl is now available on [Quicklisp](https://www.quicklisp.org). 15 | 16 | (ql:quickload :oclcl) 17 | 18 | ## Requirements 19 | 20 | oclcl requires following: 21 | 22 | * OpenCL 1.2 23 | * SBCL 1.3.1 24 | 25 | ## Test 26 | 27 | (ql:quickload '(:oclcl-tests :rove)) 28 | (rove:run :oclcl-tests) 29 | (rove:run-test 'oclcl.tests.lang.program::make-program) 30 | 31 | or 32 | 33 | $ ros install rove 34 | $ rove oclcl.asd 35 | 36 | ## Verification environments 37 | 38 | oclcl is verified to work in following environments: 39 | 40 | ### Environment 1 41 | 42 | * Ubuntu 15.04 x86_64 43 | * Intel Core i5-4210U 44 | * POCL 0.10 45 | * SBCL 1.3.1 64-bit 46 | * Roswell 0.0.3.50 47 | 48 | ### Environment 2 49 | 50 | * Ubuntu 16.04 x86\_64 51 | * NVIDIA GeForce GTX 660 52 | * OpenCL 1.2 CUDA 8.0.20 53 | * SBCL 1.3.4 64-bit 54 | * Roswell 0.0.5.59 55 | 56 | ### Environment 3 57 | 58 | * Ubuntu 14.04 x86\_64 59 | * AMD Radeon HD 5700 Series 60 | * OpenCL C 1.2 61 | * SBCL 1.3.2 64-bit 62 | * Roswell 0.0.5.58 63 | 64 | ## Kernel Description Language 65 | 66 | ### Types 67 | 68 | Support types. 69 | 70 | * `char` `char2` `char3` `char4` `char8` `char16` 71 | * `char*` `char2*` `char3*` `char4*` `char8*` `char16*` 72 | * `uchar` `uchar2` `uchar3` `uchar4` `uchar8` `uchar16` 73 | * `uchar*` `uchar2*` `uchar3*` `uchar4*` `uchar8*` `uchar16*` 74 | * `short` `short2` `short3` `short4` `short8` `short16` 75 | * `short*` `short2*` `short3*` `short4*` `short8*` `short16*` 76 | * `ushort` `ushort2` `ushort3` `ushort4` `ushort8` `ushort16` 77 | * `ushort*` `ushort2*` `ushort3*` `ushort4*` `ushort8*` `ushort16*` 78 | * `int` `int2` `int3` `int4` `int8` `int16` 79 | * `int*` `int2*` `int3*` `int4*` `int8*` `int16*` 80 | * `uint` `uint2` `uint3` `uint4` `uint8` `uint16` 81 | * `uint*` `uint2*` `uint3*` `uint4*` `uint8*` `uint16*` 82 | * `long` `long2` `long3` `long4` `long8` `long16` 83 | * `long*` `long2*` `long3*` `long4*` `long8*` `long16*` 84 | * `ulong` `ulong2` `ulong3` `ulong4` `ulong8` `ulong16` 85 | * `ulong*` `ulong2*` `ulong3*` `ulong4*` `ulong8*` `ulong16*` 86 | * `float` `float2` `float3` `float4` `float8` `float16` 87 | * `float*` `float2*` `float3*` `float4*` `float8*` `float16*` 88 | * `double` `double2` `double3` `double4` `double8` `double16` 89 | * `double*` `double2*` `double3*` `double4*` `double8*` `double16*` 90 | * `bool` `void` `size-t` 91 | 92 | ### IF statement 93 | 94 | IF test-form then-form [else-form] 95 | 96 | `if` allows the execution of a form to be dependent on a single `test-form`. First `test-form` is evaluated. If the result is `true`, then `then-form` is selected; otherwise `else-form` is selected. Whichever form is selected is then evaluated. If `else-form` is not provided, does nothing when `else-form` is selected. 97 | 98 | Example: 99 | 100 | (if (= a 0) 101 | (return 0) 102 | (return 1)) 103 | 104 | Compiled: 105 | 106 | if (a == 0) { 107 | return 0; 108 | } else { 109 | return 1; 110 | } 111 | 112 | ### LET statement 113 | 114 | LET ({(var init-form)}*) statement* 115 | 116 | `let` declares new variable bindings and set corresponding `init-form`s to them and execute a series of `statement`s that use these bindings. `let` performs the bindings in parallel. For sequentially, use `let*` kernel macro instead. 117 | 118 | Example: 119 | 120 | (let ((i 0)) 121 | (return i)) 122 | 123 | Compiled: 124 | 125 | { 126 | int i = 0; 127 | return i; 128 | } 129 | 130 | ### SYMBOL-MACROLET statement 131 | 132 | SYMBOL-MACROLET ({(symbol expansion)}*) statement* 133 | 134 | `symbol-macrolet` establishes symbol expansion rules in the variable environment and execute a series of `statement`s that use these rules. In cl-cuda's compilation process, the symbol macros found in a form are replaces by corresponding `expansion`s. 135 | 136 | Example: 137 | 138 | (symbol-macrolet ((x 1.0)) 139 | (return x)) 140 | 141 | Compiled: 142 | 143 | { 144 | return 1.0; 145 | } 146 | 147 | ### DO statement 148 | 149 | DO ({(var init-form step-form)}*) (test-form) statement* 150 | 151 | `do` iterates over a group of `statement`s while `test-form` holds. `do` accepts an arbitrary number of iteration `var`s and their initial values are supplied by `init-form`s. `step-form`s supply how the `var`s should be updated on succeeding iterations through the loop. 152 | 153 | Example: 154 | 155 | (do ((a 0 (+ a 1)) 156 | (b 0 (+ b 1))) 157 | ((> a 15)) 158 | (do-some-statement)) 159 | 160 | Compiled: 161 | 162 | for ( int a = 0, int b = 0; ! (a > 15); a = a + 1, b = b + 1 ) 163 | { 164 | do_some_statement(); 165 | } 166 | 167 | ### WITH-LOCAL-MEMORY statement 168 | 169 | WITH-LOCAL-MEMORY ({(var type size*)}*) statement* 170 | 171 | `with-local-memory` declares new variable bindings on local memory by adding `__local` variable specifiers. It allows to declare array variables if dimensions are provided. A series of `statement`s are executed with these bindings. 172 | 173 | Example: 174 | 175 | (with-local-memory ((a int 16) 176 | (b float 16 16)) 177 | (return)) 178 | 179 | Compiled: 180 | 181 | { 182 | __local int a[16]; 183 | __local float b[16][16]; 184 | return; 185 | } 186 | 187 | ### SET statement 188 | 189 | SET reference expression 190 | 191 | `set` provides simple variable assignment. It accepts one of variable, structure and array references as `reference`. 192 | 193 | Example: 194 | 195 | (set x 1.0) 196 | (set (float4-x y 1.0) 197 | (set (aref z 0) 1.0) 198 | 199 | Compiled: 200 | 201 | x = 1.0; 202 | y.x = 1.0; 203 | z[0] = 1.0; 204 | 205 | ### PROGN statement 206 | 207 | PROGN statement* 208 | 209 | `progn` evaluates `statement`s, in the order in which they are given. 210 | 211 | Example: 212 | 213 | (progn 214 | (do-some-statements) 215 | (do-more-statements)) 216 | 217 | Compiled: 218 | 219 | do_some_statements(); 220 | do_more_statements(); 221 | 222 | ### RETURN statement 223 | 224 | RETURN [return-form] 225 | 226 | `return` returns control, with `return-form` if supplied, from a kernel function. 227 | 228 | Example: 229 | 230 | (return 0) 231 | 232 | Compiled: 233 | 234 | return 0; 235 | 236 | ### Built in Functions 237 | 238 | Implementation status of built in functions. 239 | 240 | | Status | Functions | 241 | |:------:|:----------| 242 | | Yes | Work-Item | 243 | | Part | Math | 244 | | Yes | Integer | 245 | | Part | Common | 246 | | Yes | Geometric | 247 | | No | Relational | 248 | | No | Vector Data Load and Store | 249 | | Yes | Synchronization | 250 | | Yes | Explicit Memory Fence | 251 | | No | Async Copies from Global to Local Memory, Local to Global Memory, and Prefetch | 252 | | Yes | Atomic | 253 | | Yes | Miscellaneous Vector | 254 | | Yes | printf | 255 | | No | Image Read and Write Functions | 256 | 257 | ## Author 258 | 259 | * gos-k (mag4.elan@gmail.com) 260 | 261 | C source generator is forked from [cl-cuda](https://github.com/takagi/cl-cuda). 262 | 263 | ## Copyright 264 | 265 | 2015-2025 gos-k (mag4.elan@gmail.com) 266 | 267 | ### cl-cuda 268 | 269 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 270 | 271 | ## License 272 | 273 | Licensed under the LLGPL License. 274 | -------------------------------------------------------------------------------- /src/lang/compiler/compile-program.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.lang.compiler.compile-program 9 | (:use :cl 10 | :alexandria 11 | :oclcl.lang.util 12 | :oclcl.lang.type 13 | :oclcl.lang.syntax 14 | :oclcl.lang.environment 15 | :oclcl.lang.program 16 | :oclcl.lang.compiler.compile-data 17 | :oclcl.lang.compiler.compile-type 18 | :oclcl.lang.compiler.compile-expression 19 | :oclcl.lang.compiler.compile-statement 20 | :oclcl.lang.compiler.type-of-expression) 21 | (:import-from #:serapeum 22 | #:fmt) 23 | (:export :compile-program)) 24 | (in-package :oclcl.lang.compiler.compile-program) 25 | 26 | 27 | ;;; 28 | ;;; Program to Environment 29 | ;;; 30 | 31 | (defun %add-function-arguments (program name env) 32 | (flet ((aux (env0 argument) 33 | (let ((var (argument-var argument)) 34 | (type (argument-type argument))) 35 | (variable-environment-add-variable var type env0)))) 36 | (reduce #'aux (program-function-arguments program name) 37 | :initial-value env))) 38 | 39 | (defun %add-symbol-macros (program env) 40 | (flet ((aux (env0 name) 41 | (let ((expansion (program-symbol-macro-expansion program name))) 42 | (variable-environment-add-symbol-macro name expansion env0)))) 43 | (reduce #'aux (program-symbol-macro-names program) 44 | :initial-value env))) 45 | 46 | (defun %add-memories (program env) 47 | (flet ((aux (env0 name) 48 | (let* ((expression (program-memory-expression program name)) 49 | (type (type-of-expression expression (empty-environment)))) 50 | (variable-environment-add-memory name type expression env0)))) 51 | (reduce #'aux (program-memory-names program) 52 | :initial-value env))) 53 | 54 | (defun %add-functions (program env) 55 | (flet ((aux (env0 name) 56 | (let ((return-type (program-function-return-type program name)) 57 | (argument-types (program-function-argument-types program 58 | name))) 59 | (function-environment-add-function name return-type 60 | argument-types env0)))) 61 | (reduce #'aux (program-function-names program) 62 | :initial-value env))) 63 | 64 | (defun %add-macros (program env) 65 | (flet ((aux (env0 name) 66 | (let ((arguments (program-macro-arguments program name)) 67 | (body (program-macro-body program name))) 68 | (function-environment-add-macro name arguments body env0)))) 69 | (reduce #'aux (program-macro-names program) 70 | :initial-value env))) 71 | 72 | (defun program->environment (program &optional name) 73 | (let* ((env (empty-environment)) 74 | (env (%add-macros program env)) 75 | (env (%add-functions program env)) 76 | (env (%add-memories program env)) 77 | (env (%add-symbol-macros program env))) 78 | (if name 79 | (%add-function-arguments program name env) 80 | env))) 81 | 82 | 83 | ;;; 84 | ;;; Compile program 85 | ;;; 86 | 87 | (defun compile-includes () 88 | nil) 89 | 90 | (defun compile-function-qualifier (return-type) 91 | (unless (oclcl-type-p return-type) 92 | (error 'type-error :datum return-type :expected 'oclcl-type)) 93 | ;; OpenCL v1.2 dr19: 6.7 Function Qualifiers 94 | (if (eq return-type 'void) 95 | "__kernel" 96 | nil)) 97 | 98 | (defun compile-address-space-qualifier (qualifier) 99 | (fmt "__~A" (string-downcase (princ-to-string qualifier)))) 100 | 101 | (defun compile-memory (program name) 102 | (let ((c-name (program-memory-c-name program name)) 103 | (qualifiers (program-address-space-qualifiers program name)) 104 | (expression (program-memory-expression program name))) 105 | (let* ((env (program->environment program)) 106 | (type1 (compile-type 107 | (type-of-expression expression (empty-environment)))) 108 | (qualifiers1 (mapcar #'compile-address-space-qualifier qualifiers)) 109 | (expression1 (compile-expression expression env))) 110 | (fmt "~{~A~^ ~} ~A ~A~@[ = ~A~];~%" 111 | qualifiers1 type1 c-name expression1)))) 112 | 113 | (defun compile-memories (program) 114 | (flet ((aux (name) 115 | (compile-memory program name))) 116 | (let ((memories (mapcar #'aux (program-memory-names program)))) 117 | (when memories 118 | (fmt "/** 119 | * Memory objects 120 | */ 121 | 122 | ~{~A~}" memories))))) 123 | 124 | (defun compile-argument (argument) 125 | (let ((var (argument-var argument)) 126 | (type (argument-type argument))) 127 | (let ((var1 (compile-symbol var)) 128 | (type1 (compile-type type))) 129 | (fmt "~A ~A" type1 var1)))) 130 | 131 | (defun compile-arguments (arguments) 132 | (let ((arguments1 (mapcar #'compile-argument arguments))) 133 | (if arguments1 134 | (fmt "~{~A~^, ~}" arguments1) 135 | ""))) 136 | 137 | (defun compile-declaration (program name) 138 | (let ((c-name (program-function-c-name program name)) 139 | (return-type (program-function-return-type program name)) 140 | (arguments (program-function-arguments program name))) 141 | (let ((function-qualifier (compile-function-qualifier return-type)) 142 | (return-type1 (compile-type return-type)) 143 | (arguments1 (compile-arguments arguments))) 144 | (if function-qualifier 145 | (fmt "~A ~A ~A(~A)" function-qualifier return-type1 c-name arguments1) 146 | (fmt "~A ~A(~A)" return-type1 c-name arguments1))))) 147 | 148 | (defun compile-prototype (program name) 149 | (let ((declaration (compile-declaration program name))) 150 | (fmt "~A;~%" declaration))) 151 | 152 | (defun compile-prototypes (program) 153 | (flet ((aux (name) 154 | (compile-prototype program name))) 155 | (let ((prototypes (mapcar #'aux (reverse (program-function-names program))))) 156 | (when prototypes 157 | (fmt "/** 158 | * Kernel function prototypes 159 | */ 160 | 161 | ~{~A~}" prototypes))))) 162 | 163 | (defun compile-statements (program name) 164 | (let ((env (program->environment program name))) 165 | (flet ((aux (statement) 166 | (compile-statement statement env))) 167 | (let ((statements (program-function-body program name))) 168 | (fmt "~{~A~}" (mapcar #'aux statements)))))) 169 | 170 | (defun compile-definition (program name) 171 | (let ((declaration (compile-declaration program name)) 172 | (statements (compile-statements program name))) 173 | (let ((statements1 (indent 2 statements))) 174 | (fmt "~A~%{~%~A}~%" declaration statements1)))) 175 | 176 | (defun compile-definitions (program) 177 | (flet ((aux (name) 178 | (compile-definition program name))) 179 | (let ((definitions (mapcar #'aux (reverse (program-function-names program))))) 180 | (when definitions 181 | (fmt "/** 182 | * Kernel function definitions 183 | */ 184 | 185 | ~{~A~^~%~}" definitions))))) 186 | 187 | (defun compile-define (program name) 188 | (let ((c-name (program-define-c-name program name)) 189 | (expression (program-define-expression program name))) 190 | (let ((expression1 (compile-expression expression 191 | (program->environment program)))) 192 | (fmt "#define ~A ~A~%" c-name expression1)))) 193 | 194 | (defun compile-defines (program) 195 | (let ((defines (mapcar (curry #'compile-define program) 196 | (program-define-names program)))) 197 | (when defines 198 | (fmt "/** 199 | * Define 200 | */ 201 | 202 | ~{~A~}" defines)))) 203 | 204 | (defun compile-program (program) 205 | (let ((parts (list (compile-defines program) 206 | (compile-memories program) 207 | (compile-prototypes program) 208 | (compile-definitions program)))) 209 | (fmt "~{~A~^~%~%~}" (remove-if #'null parts)))) -------------------------------------------------------------------------------- /examples/diffuse1-oclapi.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2016 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl-examples.diffuse1-oclapi 9 | (:use :cl 10 | :cffi 11 | :oclcl 12 | :cl-oclapi) 13 | (:export :main)) 14 | (in-package :oclcl-examples.diffuse1-oclapi) 15 | 16 | (define-program :diffuse1-oclapi 17 | (:use :oclcl)) 18 | (in-program :diffuse1-oclapi) 19 | 20 | ;;; image output functions 21 | 22 | (declaim (inline index)) 23 | (defun index (nx jx jy) 24 | (the fixnum (+ (the fixnum (* nx jy)) jx))) 25 | 26 | (defun image-value (f i j nx fmax fmin) 27 | (let ((fc (mem-aref 'cl-float f (index nx i j)))) 28 | (truncate (* 256.0 29 | (/ (- fc fmin) (- fmax fmin)))))) 30 | 31 | (defun file-name (dir i nout) 32 | (let ((n (truncate (/ i nout)))) 33 | (concatenate 'string dir (format nil "~4,'0D.pgm" n)))) 34 | 35 | (defun output-pnm (dir i nout nx ny f) 36 | (let ((image (make-instance 'imago:grayscale-image 37 | :width nx :height ny))) 38 | (dotimes (i nx) 39 | (dotimes (j ny) 40 | (setf (imago:image-pixel image i j) (image-value f i j nx 1.0 0.0)))) 41 | (imago:write-pnm image (file-name dir i nout) :ASCII)) 42 | (values)) 43 | 44 | 45 | ;;; print functions 46 | 47 | (defun print-elapsed-time (elapsed-time) 48 | (let ((time (* elapsed-time 1.0e-3))) 49 | (format t "Elapsed Time = ~,3F [sec]~%" time))) 50 | 51 | (defun print-performance (flo elapsed-time) 52 | (let ((time (* elapsed-time 1.0e-3))) 53 | (format t "Performance = ~,2F [MFlops]~%" (* (/ flo time) 1.0e-6)))) 54 | 55 | (defun print-time (cnt time) 56 | (format t "time(~A) = ~,5F~%" cnt time)) 57 | 58 | 59 | ;;; main functions 60 | 61 | (defkernel diffusion2d (void ((f float*) (fn float*) 62 | (nx int) (ny int) 63 | (c0 float) (c1 float) (c2 float))) 64 | (let ((local-id-x (to-int (get-local-id 0))) 65 | (local-id-y (to-int (get-local-id 1))) 66 | (global-id-x (to-int (get-global-id 0))) 67 | (global-id-y (to-int (get-global-id 1))) 68 | (local-size-x (to-int (get-local-size 0))) 69 | (local-size-y (to-int (get-local-size 1))) 70 | (group-id-x (to-int (get-group-id 0))) 71 | (group-id-y (to-int (get-group-id 1))) 72 | (num-groups-x (to-int (get-num-groups 0))) 73 | (num-groups-y (to-int (get-num-groups 1)))) 74 | (let* ((jx (+ local-id-x 1)) 75 | (jy (+ local-id-y 1)) 76 | (j (+ (* nx global-id-y) global-id-x)) 77 | (fcc (aref f j))) 78 | (with-local-memory ((fs float (+ 16 2) (+ 16 2))) 79 | (set (aref fs jy jx) fcc) 80 | (if (= local-id-x 0) 81 | (if (= group-id-x 0) 82 | (set (aref fs jy 0) fcc) 83 | (set (aref fs jy 0) (aref f (- j 1))))) 84 | (if (= local-id-x (- local-size-x 1)) 85 | (if (= group-id-x (- num-groups-x 1)) 86 | (set (aref fs jy (+ local-size-x 1)) fcc) 87 | (set (aref fs jy (+ local-size-x 1)) (aref f (+ j 1))))) 88 | (if (= local-id-y 0) 89 | (if (= group-id-y 0) 90 | (set (aref fs 0 jx) fcc) 91 | (set (aref fs 0 jx) (aref f (- j nx))))) 92 | (if (= local-id-y (- local-size-y 1)) 93 | (if (= group-id-y (- num-groups-y 1)) 94 | (set (aref fs (+ local-size-y 1) jx) fcc) 95 | (set (aref fs (+ local-size-y 1) jx) (aref f (+ j nx))))) 96 | (barrier :clk-local-mem-fence) 97 | (set (aref fn j) (+ (* c0 (+ (aref fs jy (+ jx 1)) 98 | (aref fs jy (- jx 1)))) 99 | (* c1 (+ (aref fs (+ jy 1) jx) 100 | (aref fs (- jy 1) jx))) 101 | (* c2 (aref fs jy jx)))))))) 102 | 103 | (defun initialize-device-memory (nx ny dx dy command-queue host-memory device-memory) 104 | (let ((alpha 30.0)) 105 | (dotimes (jy ny) 106 | (dotimes (jx nx) 107 | (let ((j (index nx jx jy)) 108 | (x (- (* dx (+ (float jx 1.0) 0.5)) 0.5)) 109 | (y (- (* dy (+ (float jy 1.0) 0.5)) 0.5))) 110 | (setf (mem-aref host-memory :float j) 111 | (exp (* (- alpha) 112 | (+ (* x x) (* y y))))))))) 113 | 114 | (enqueue-write-buffer command-queue 115 | device-memory 116 | +cl-true+ 117 | 0 118 | (* (foreign-type-size :float) 119 | (* nx ny)) 120 | host-memory) 121 | (finish command-queue)) 122 | 123 | (defun diffusion2d (nx ny command-queue kernel f fn kappa dt dx dy) 124 | (let* ((c0 (* kappa (/ dt (* dx dx)))) 125 | (c1 (* kappa (/ dt (* dy dy)))) 126 | (c2 (- 1.0 (* 2.0 (+ c0 c1))))) 127 | (with-work-size (global-work-size nx ny) 128 | (with-pointers ((f-pointer f) 129 | (fn-pointer fn)) 130 | (with-foreign-objects ((%nx 'cl-int) 131 | (%ny 'cl-int) 132 | (%c0 'cl-float) 133 | (%c1 'cl-float) 134 | (%c2 'cl-float)) 135 | (setf (mem-aref %nx 'cl-int) nx) 136 | (setf (mem-aref %ny 'cl-int) ny) 137 | (setf (mem-aref %c0 'cl-float) c0) 138 | (setf (mem-aref %c1 'cl-float) c1) 139 | (setf (mem-aref %c2 'cl-float) c2) 140 | (set-kernel-arg kernel 0 8 f-pointer) 141 | (set-kernel-arg kernel 1 8 fn-pointer) 142 | (set-kernel-arg kernel 2 4 %nx) 143 | (set-kernel-arg kernel 3 4 %ny) 144 | (set-kernel-arg kernel 4 4 %c0) 145 | (set-kernel-arg kernel 5 4 %c1) 146 | (set-kernel-arg kernel 6 4 %c2) 147 | (enqueue-ndrange-kernel command-queue 148 | kernel 149 | 2 150 | global-work-size 151 | (null-pointer))) 152 | (finish command-queue) 153 | (* nx ny 7.0))))) 154 | 155 | (defmacro swap (a b) 156 | `(rotatef ,a ,b)) 157 | 158 | (defun main () 159 | (let* ((nx 256) (ny 256) 160 | (Lx 1.0) (Ly 1.0) 161 | (dx (/ Lx (float nx 1.0))) 162 | (dy (/ Ly (float ny 1.0))) 163 | (kappa 0.1) 164 | (dt (/ (* 0.2 (min (* dx dx) (* dy dy))) kappa)) 165 | (time 0) 166 | (flo 0) 167 | (elements (* nx ny)) 168 | (float-size (foreign-type-size 'cl-float)) 169 | (data-bytes (* float-size elements)) 170 | (*program* (find-program :diffuse1-oclapi)) 171 | (c-source-code (compile-program *program*))) 172 | (with-platform-id (platform) 173 | (with-device-ids (devices num-devices platform) 174 | (with-context (context (null-pointer) 1 devices) 175 | (with-program-with-source (program context 1 c-source-code) 176 | (build-program program 1 devices) 177 | (with-foreign-objects ((a-host 'cl-float elements) 178 | (b-host 'cl-float elements)) 179 | (with-buffers ((a-device context +cl-mem-read-only+ data-bytes) 180 | (b-device context +cl-mem-write-only+ data-bytes)) 181 | (let ((device (mem-aref devices 'cl-device-id))) 182 | (with-command-queue (command-queue context device 0) 183 | (initialize-device-memory nx ny dx dy command-queue a-host a-device) 184 | (with-work-size (global-work-size elements) 185 | (with-kernel (kernel program (program-function-c-name *program* 'diffusion2d)) 186 | (dotimes (i 20000) 187 | (when (= (mod i 100) 0) 188 | (print-time i time)) 189 | (incf flo (diffusion2d nx ny command-queue kernel a-device b-device kappa dt dx dy)) 190 | (incf time dt) 191 | (swap a-device b-device)))))))))))))) 192 | -------------------------------------------------------------------------------- /tests/lang/environment.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.tests.lang.environment 9 | (:use :cl :rove 10 | :arrow-macros 11 | :oclcl.tests.utils 12 | :oclcl.lang.type 13 | :oclcl.lang.environment)) 14 | (in-package :oclcl.tests.lang.environment) 15 | 16 | ;;; 17 | ;;; test Variable environment - Variable 18 | ;;; 19 | 20 | (deftest variable-environment-variable 21 | (let ((env (->> (empty-environment) 22 | (variable-environment-add-variable 'x 'int) 23 | (variable-environment-add-symbol-macro 'y 1.0)))) 24 | (is (variable-environment-variable-exists-p env 'x) t 25 | "basic case 1") 26 | (is (variable-environment-variable-exists-p env 'y) nil 27 | "basic case 2") 28 | (is (variable-environment-variable-exists-p env 'z) nil 29 | "basic case 3") 30 | (is (variable-environment-variable-name env 'x) 'x 31 | "basic case 4") 32 | (is (variable-environment-variable-type env 'x) 'int 33 | "basic case 5")) 34 | 35 | (let ((env (->> (empty-environment) 36 | (variable-environment-add-variable 'x 'int) 37 | (variable-environment-add-variable 'x 'float)))) 38 | (is (variable-environment-variable-type env 'x) 'float 39 | "basic case 6")) 40 | 41 | (let ((env (->> (empty-environment) 42 | (variable-environment-add-variable 'x 'int) 43 | (variable-environment-add-symbol-macro 'x '1.0)))) 44 | (is (variable-environment-variable-exists-p env 'x) nil 45 | "basic case 7") 46 | (is (variable-environment-symbol-macro-exists-p env 'x) t 47 | "basic case 8"))) 48 | 49 | 50 | ;;; 51 | ;;; test Variable environment - Symbol macro 52 | ;;; 53 | 54 | (deftest variable-environment-symbol-macro 55 | (let ((env (->> (empty-environment) 56 | (variable-environment-add-variable 'x 'int) 57 | (variable-environment-add-symbol-macro 'y 1.0)))) 58 | (is (variable-environment-symbol-macro-exists-p env 'x) nil 59 | "basic case 1") 60 | (is (variable-environment-symbol-macro-exists-p env 'y) t 61 | "basic case 2") 62 | (is (variable-environment-symbol-macro-exists-p env 'z) nil 63 | "basic case 3") 64 | (is (variable-environment-symbol-macro-name env 'y) 'y 65 | "basic case 4") 66 | (is (variable-environment-symbol-macro-expansion env 'y) 1.0 67 | "basic case 5"))) 68 | 69 | 70 | ;;; 71 | ;;; test Function environment - Function 72 | ;;; 73 | 74 | (deftest function-environment-function 75 | (let ((env (->> (empty-environment) 76 | (function-environment-add-function 'foo 'int '(int)) 77 | (function-environment-add-macro 'bar '(x) '(`(return ,x)))))) 78 | (is (function-environment-function-exists-p env 'foo) t 79 | "basic case 1") 80 | (is (function-environment-function-exists-p env 'bar) nil 81 | "basic case 2") 82 | (is (function-environment-function-exists-p env 'baz) nil 83 | "basic case 3") 84 | (is (function-environment-function-name env 'foo) 'foo 85 | "basic case 4") 86 | (is (function-environment-function-c-name env 'foo) "oclcl_tests_lang_environment_foo" 87 | "basic case 5") 88 | (is (function-environment-function-return-type env 'foo) 'int 89 | "basic case 6") 90 | (is (function-environment-function-argument-types env 'foo) '(int) 91 | "basic case 7"))) 92 | 93 | 94 | ;;; test Variable environment - Memory 95 | ;;; 96 | 97 | (deftest variable-environment-memory 98 | (let ((env (variable-environment-add-variable 'z 'int 99 | (variable-environment-add-memory 'y 'int nil 100 | (variable-environment-add-memory 'x 'int 1 101 | (empty-environment)))))) 102 | (is (variable-environment-memory-exists-p env 'x) t 103 | "basic case 1") 104 | (is (variable-environment-memory-exists-p env 'y) t 105 | "basic case 2") 106 | (is (variable-environment-memory-exists-p env 'z) nil 107 | "basic case 3") 108 | (is (variable-environment-memory-name env 'x) 'x 109 | "basic case 4") 110 | (is (variable-environment-memory-c-name env 'x) 111 | "oclcl_tests_lang_environment_x" 112 | "basic case 5") 113 | (is (variable-environment-memory-type env 'x) 'int 114 | "basic case 6") 115 | (is (variable-environment-memory-expression env 'x) 1 116 | "basic case 7") 117 | (is (variable-environment-memory-expression env 'y) nil 118 | "basic case 8")) 119 | 120 | (ok (signals (variable-environment-add-memory 1 'int 1 121 | (empty-environment)) 122 | 'type-error) 123 | "Invalid name.") 124 | 125 | (ok (signals (variable-environment-add-memory 'x :foo 1 126 | (empty-environment)) 127 | 'type-error) 128 | "Invalid cl-cuda type.") 129 | 130 | (ok (signals (variable-environment-add-memory 'x 'int 1 131 | :foo) 132 | 'type-error) 133 | "Invalid variable environment.") 134 | 135 | (ok (signals (variable-environment-memory-exists-p :foo 'x) 136 | 'type-error) 137 | "Invalid variable environment.") 138 | 139 | (ok (signals (variable-environment-memory-exists-p (empty-environment) 1) 140 | 'type-error) 141 | "Invalid name.") 142 | 143 | (ok (signals (variable-environment-memory-name :foo 'x) 144 | 'type-error) 145 | "Invalid variable environment.") 146 | 147 | (ok (signals (variable-environment-memory-name (empty-environment) 1) 148 | 'type-error) 149 | "Invalid name.") 150 | 151 | (ok (signals (variable-environment-memory-c-name :foo 'x) 152 | 'type-error) 153 | "Invalid variable environment.") 154 | 155 | (ok (signals (variable-environment-memory-c-name (empty-environment) 1) 156 | 'type-error) 157 | "Invalid name.") 158 | 159 | (ok (signals (variable-environment-memory-type :foo 'x) 160 | 'type-error) 161 | "Invalid variable environment.") 162 | 163 | (ok (signals (variable-environment-memory-type (empty-environment) 1) 164 | 'type-error) 165 | "Invalid name.") 166 | 167 | (ok (signals (variable-environment-memory-expression :foo 'x) 168 | 'type-error) 169 | "Invalid variable environment.") 170 | 171 | (ok (signals (variable-environment-memory-expression (empty-environment) 172 | 1) 173 | 'type-error) 174 | "Invalid name.")) 175 | 176 | ;;; 177 | ;;; test Function environment - Macro 178 | ;;; 179 | 180 | (deftest function-environment-macro 181 | (let ((env (->> (empty-environment) 182 | (function-environment-add-function 'foo 'int '(int)) 183 | (function-environment-add-macro 'bar '(x) '(`(return ,x)))))) 184 | (is (function-environment-macro-exists-p env 'foo) nil 185 | "basic case 1") 186 | (is (function-environment-macro-exists-p env 'bar) t 187 | "basic case 2") 188 | (is (function-environment-macro-exists-p env 'baz) nil 189 | "basic case 3") 190 | (is (function-environment-macro-name env 'bar) 'bar 191 | "basic case 4") 192 | (is (funcall (function-environment-macro-expander env 'bar) '(1)) 193 | '(return 1) 194 | "basic case 5"))) 195 | 196 | ;;; 197 | ;;; test Define environment - Define 198 | ;;; 199 | 200 | (deftest define-environment-define 201 | (let ((env (->> (empty-environment) 202 | (define-environment-add-define 'x 1) 203 | (define-environment-add-define 'y nil)))) 204 | (ok (define-environment-define-exists-p env 'x)) 205 | (ok (define-environment-define-exists-p env 'y)) 206 | (ng (define-environment-define-exists-p env 'z)) 207 | (is (define-environment-define-name env 'x) 'x) 208 | (is (define-environment-define-c-name env 'x) 209 | "oclcl_tests_lang_environment_x") 210 | (is (define-environment-define-expression env 'x) 1) 211 | (ng (define-environment-define-expression env 'y))) 212 | 213 | (ok (signals (define-environment-add-define 1 1 (empty-environment)) 214 | 'type-error) 215 | "Invalid name.") 216 | 217 | (ok (signals (define-environment-add-define 'x 1 :foo) 218 | 'type-error) 219 | "Invalid define environment.") 220 | 221 | (ok (signals (define-environment-define-exists-p :foo 'x) 222 | 'type-error) 223 | "Invalid define environment.") 224 | 225 | (ok (signals (define-environment-define-exists-p (empty-environment) 1) 226 | 'type-error) 227 | "Invalid name.") 228 | 229 | (ok (signals (define-environment-define-name :foo 'x) 230 | 'type-error) 231 | "Invalid define environment.") 232 | 233 | (ok (signals (define-environment-define-name (empty-environment) 1) 234 | 'type-error) 235 | "Invalid name.") 236 | 237 | (ok (signals (define-environment-define-c-name :foo 'x) 238 | 'type-error) 239 | "Invalid define environment.") 240 | 241 | (ok (signals (define-environment-define-c-name (empty-environment) 1) 242 | 'type-error) 243 | "Invalid name.") 244 | 245 | (ok (signals (define-environment-define-expression :foo 'x) 246 | 'type-error) 247 | "Invalid define environment.") 248 | 249 | (ok (signals (define-environment-define-expression (empty-environment) 1) 250 | 'type-error) 251 | "Invalid name.")) -------------------------------------------------------------------------------- /src/lang/type.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.lang.type 9 | (:use :cl 10 | :oclcl.lang.data) 11 | (:export ;; opencl types 12 | :bool 13 | :bool* 14 | :char :char2 :char3 :char4 :char8 :char16 15 | :char* :char2* :char3* :char4* :char8* :char16* 16 | :uchar :uchar2 :uchar3 :uchar4 :uchar8 :uchar16 17 | :uchar* :uchar2* :uchar3* :uchar4* :uchar8* :uchar16* 18 | :short :short2 :short3 :short4 :short8 :short16 19 | :short* :short2* :short3* :short4* :short8* :short16* 20 | :ushort :ushort2 :ushort3 :ushort4 :ushort8 :ushort16 21 | :ushort* :ushort2* :ushort3* :ushort4* :ushort8* :ushort16* 22 | :int :int2 :int3 :int4 :int8 :int16 23 | :int* :int2* :int3* :int4* :int8* :int16* 24 | :uint :uint2 :uint3 :uint4 :uint8 :uint16 25 | :uint* :uint2* :uint3* :uint4* :uint8* :uint16* 26 | :long :long2 :long3 :long4 :long8 :long16 27 | :long* :long2* :long3* :long4* :long8* :long16* 28 | :ulong :ulong2 :ulong3 :ulong4 :ulong8 :ulong16 29 | :ulong* :ulong2* :ulong3* :ulong4* :ulong8* :ulong16* 30 | ;:float :float2 :float3 :float4 :float8 :float16 31 | :float :float2 :float8 :float16 32 | :float* :float2* :float3* :float4* :float8* :float16* 33 | ;:double :double2 :double3 :double4 :double8 :double16 34 | :double :double2 :double8 :double16 35 | :double* :double2* :double3* :double4* :double8* :double16* 36 | :size-t 37 | :void 38 | :cl-mem-fence-flags 39 | ;; Type 40 | :oclcl-type 41 | :oclcl-type-p 42 | :cffi-type 43 | :cffi-type-size 44 | :opencl-type 45 | ;; Scalar type 46 | :scalar-type-p 47 | :scalar-integer-type-p 48 | :scalar-float-type-p 49 | ;; Structure type 50 | :structure-type-p 51 | ;; Structure accessor 52 | :structure-accessor-p 53 | :structure-from-accessor 54 | :structure-accessor-opencl-accessor 55 | :structure-accessor-return-type 56 | ;; Array type 57 | :array-type-p 58 | :array-type-base 59 | :array-type-dimension 60 | :array-type) 61 | (:import-from :alexandria 62 | :format-symbol) 63 | (:import-from #:serapeum 64 | #:fmt)) 65 | (in-package :oclcl.lang.type) 66 | 67 | 68 | ;;; 69 | ;;; Type 70 | ;;; 71 | 72 | (deftype oclcl-type () 73 | `(satisfies oclcl-type-p)) 74 | 75 | (defun oclcl-type-p (object) 76 | (or (scalar-type-p object) 77 | (structure-type-p object) 78 | (array-type-p object))) 79 | 80 | (defun cffi-type (type) 81 | (cond 82 | ((scalar-type-p type) (scalar-cffi-type type)) 83 | ((structure-type-p type) (structure-cffi-type type)) 84 | ((array-type-p type) (array-cffi-type type)) 85 | (t (error "The value ~S is an invalid type." type)))) 86 | 87 | (defun cffi-type-size (type) 88 | (cond 89 | ((scalar-type-p type) (scalar-cffi-type-size type)) 90 | ((structure-type-p type) (structure-cffi-type-size type)) 91 | ((array-type-p type) (array-cffi-type-size type)) 92 | (t (error "The value ~S is an invalid type." type)))) 93 | 94 | (defun opencl-type (type) 95 | (cond 96 | ((scalar-type-p type) (scalar-opencl-type type)) 97 | ((structure-type-p type) (structure-opencl-type type)) 98 | ((array-type-p type) (array-opencl-type type)) 99 | (t (error "The value ~S is an invalid type." type)))) 100 | 101 | 102 | ;;; 103 | ;;; Scalar type 104 | ;;; 105 | 106 | (defparameter +scalar-types+ 107 | '((void :void "void") 108 | (bool (:boolean :int8) "bool") 109 | (char :char "char") 110 | (uchar :uchar "uchar") 111 | (short :short "short") 112 | (ushort :ushort "ushort") 113 | (int :int "int") 114 | (uint :uint "uint") 115 | (long :long "long") 116 | (ulong :ulong "ulong") 117 | (float :float "float") 118 | (double :double "double") 119 | (size-t :size-t "size_t") 120 | (cl-mem-fence-flags :int "cl_mem_fence_flags"))) 121 | 122 | (defparameter +scalar-integer-types+ 123 | '(bool char uchar short ushort int uint long ulong size-t)) 124 | 125 | (defparameter +scalar-float-types+ 126 | '(oclcl.lang.type:float double)) 127 | 128 | (defun scalar-type-p (object) 129 | (and (assoc object +scalar-types+) 130 | t)) 131 | 132 | (defun scalar-integer-type-p (object) 133 | (and (member object +scalar-integer-types+) 134 | t)) 135 | 136 | (defun scalar-float-type-p (object) 137 | (and (member object +scalar-float-types+) 138 | t)) 139 | 140 | (defun scalar-cffi-type (type) 141 | (unless (scalar-type-p type) 142 | (error "The vaue ~S is an invalid type." type)) 143 | (cadr (assoc type +scalar-types+))) 144 | 145 | (defun scalar-cffi-type-size (type) 146 | (cffi:foreign-type-size (scalar-cffi-type type))) 147 | 148 | (defun scalar-opencl-type (type) 149 | (unless (scalar-type-p type) 150 | (error "The vaue ~S is an invalid type." type)) 151 | (caddr (assoc type +scalar-types+))) 152 | 153 | 154 | ;;; 155 | ;;; Structure type 156 | ;;; 157 | 158 | (defparameter +structure-table+ 159 | '((float3 "float3" ((float3-x "x" float) 160 | (float3-y "y" float) 161 | (float3-z "z" float))) 162 | (float4 "float4" ((float4-x "x" float) 163 | (float4-y "y" float) 164 | (float4-z "z" float) 165 | (float4-w "w" float))) 166 | (double3 "double3" ((double3-x "x" double) 167 | (double3-y "y" double) 168 | (double3-z "z" double))) 169 | (double4 "double4" ((double4-x "x" double) 170 | (double4-y "y" double) 171 | (double4-z "z" double) 172 | (double4-w "w" double))))) 173 | 174 | (defparameter +structure-types+ 175 | (mapcar #'car +structure-table+)) 176 | 177 | (defun structure-type-p (object) 178 | (and (member object +structure-types+) 179 | t)) 180 | 181 | (defun structure-cffi-type (type) 182 | (unless (structure-type-p type) 183 | (error "The vaue ~S is an invalid type." type)) 184 | `(:struct ,type)) 185 | 186 | (defun structure-cffi-type-size (type) 187 | (cffi:foreign-type-size (structure-cffi-type type))) 188 | 189 | (defun structure-opencl-type (type) 190 | (unless (structure-type-p type) 191 | (error "The vaue ~S is an invalid type." type)) 192 | (cadr (assoc type +structure-table+))) 193 | 194 | (defun structure-accessors (type) 195 | (unless (structure-type-p type) 196 | (error "The vaue ~S is an invalid type." type)) 197 | (caddr (assoc type +structure-table+))) 198 | 199 | 200 | ;;; 201 | ;;; Structure type - accessor 202 | ;;; 203 | 204 | (defparameter +accessor->structure+ 205 | (loop for structure in +structure-types+ 206 | append (loop for (accessor nil nil) in (structure-accessors structure) 207 | collect (list accessor structure)))) 208 | 209 | (defun %structure-from-accessor (accessor) 210 | (cadr (assoc accessor +accessor->structure+))) 211 | 212 | (defun structure-accessor-p (accessor) 213 | (and (%structure-from-accessor accessor) 214 | t)) 215 | 216 | (defun structure-from-accessor (accessor) 217 | (or (%structure-from-accessor accessor) 218 | (error "The value ~S is not a structure accessor." accessor))) 219 | 220 | (defun structure-accessor-opencl-accessor (accessor) 221 | (let ((structure (structure-from-accessor accessor))) 222 | (second (assoc accessor (structure-accessors structure))))) 223 | 224 | (defun structure-accessor-return-type (accessor) 225 | (let ((structure (structure-from-accessor accessor))) 226 | (third (assoc accessor (structure-accessors structure))))) 227 | 228 | 229 | ;;; 230 | ;;; Array type 231 | ;;; 232 | 233 | (defparameter +array-type-regex+ 234 | "^([^\\*]+)(\\*+)$") 235 | 236 | (defun array-type-p (object) 237 | (when (symbolp object) 238 | (let ((package (symbol-package object)) 239 | (object-string (princ-to-string object))) 240 | (cl-ppcre:register-groups-bind (base-string nil) 241 | (+array-type-regex+ object-string) 242 | (let ((base (intern (string base-string) package))) 243 | (oclcl-type-p base)))))) 244 | 245 | (defun array-type-base (type) 246 | (unless (array-type-p type) 247 | (error "The value ~S is an invalid type." type)) 248 | (let ((type-string (princ-to-string type))) 249 | (cl-ppcre:register-groups-bind (base-string nil) 250 | (+array-type-regex+ type-string) 251 | (intern (string base-string) 'oclcl.lang.type)))) 252 | 253 | (defun array-type-stars (type) 254 | (unless (array-type-p type) 255 | (error "The value ~S is an invalid type." type)) 256 | (let ((type-string (princ-to-string type))) 257 | (cl-ppcre:register-groups-bind (_ stars-string) 258 | (+array-type-regex+ type-string) 259 | (declare (ignore _)) 260 | (intern (string stars-string) 'oclcl.lang.type)))) 261 | 262 | (defun array-type-dimension (type) 263 | (length (princ-to-string (array-type-stars type)))) 264 | 265 | (defun array-cffi-type (type) 266 | (unless (array-type-p type) 267 | (error "The value ~S is an invalid type." type)) 268 | 'cu-device-ptr) 269 | 270 | (defun array-cffi-type-size (type) 271 | (cffi:foreign-type-size (array-cffi-type type))) 272 | 273 | (defun array-opencl-type (type) 274 | (let ((base (array-type-base type)) 275 | (stars (array-type-stars type))) 276 | (fmt "__global ~A~A" (opencl-type base) stars))) 277 | 278 | (defun array-type (type dimension) 279 | (unless (and (oclcl-type-p type) 280 | (not (array-type-p type))) 281 | (error "The value ~S is an invalid type." type)) 282 | (let ((stars (loop repeat dimension collect #\*))) 283 | (format-symbol 'oclcl.lang.type "~A~{~A~}" type stars))) 284 | -------------------------------------------------------------------------------- /src/lang/compiler/compile-expression.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.lang.compiler.compile-expression 9 | (:use :cl 10 | :oclcl.lang.util 11 | :oclcl.lang.type 12 | :oclcl.lang.syntax 13 | :oclcl.lang.environment 14 | :oclcl.lang.built-in 15 | :oclcl.lang.compiler.compile-data 16 | :oclcl.lang.compiler.type-of-expression) 17 | (:import-from #:serapeum 18 | #:fmt) 19 | (:export :compile-expression)) 20 | (in-package :oclcl.lang.compiler.compile-expression) 21 | 22 | 23 | ;;; 24 | ;;; Compile expression 25 | ;;; 26 | 27 | (defun compile-expression (form env) 28 | (cond 29 | ((%macro-p form env) (compile-macro form env)) 30 | ((%symbol-macro-p form env) 31 | (compile-symbol-macro form env)) 32 | ((literal-p form) (compile-literal form)) 33 | ((opencl-literal-p form) (compile-opencl-literal form)) 34 | ((reference-p form) (compile-reference form env)) 35 | ((inline-if-p form) (compile-inline-if form env)) 36 | ((sizeof-p form) (compile-sizeof form env)) 37 | ((arithmetic-p form) (compile-arithmetic form env)) 38 | ((function-p form) (compile-function form env)) 39 | (t (error "The value ~S is an invalid expression." form)))) 40 | 41 | 42 | ;;; 43 | ;;; Macro 44 | ;;; 45 | 46 | (defun %macro-p (form env) 47 | (oclcl.lang.compiler.type-of-expression::%macro-p form env)) 48 | 49 | (defun compile-macro (form env) 50 | (let ((operator (macro-operator form)) 51 | (operands (macro-operands form))) 52 | (let ((expander (function-environment-macro-expander env operator))) 53 | (let ((form1 (funcall expander operands))) 54 | (compile-expression form1 env))))) 55 | 56 | 57 | ;;; 58 | ;;; Symbol macro 59 | ;;; 60 | 61 | (defun %symbol-macro-p (form env) 62 | (oclcl.lang.compiler.type-of-expression::%symbol-macro-p form env)) 63 | 64 | (defun compile-symbol-macro (form env) 65 | (let ((form1 (variable-environment-symbol-macro-expansion env form))) 66 | (compile-expression form1 env))) 67 | 68 | 69 | ;;; 70 | ;;; Literal 71 | ;;; 72 | 73 | (defun compile-literal (form) 74 | (cond 75 | ((bool-literal-p form) (compile-bool-literal form)) 76 | ((int-literal-p form) (compile-int-literal form)) 77 | ((float-literal-p form) (compile-float-literal form)) 78 | ((double-literal-p form) (compile-double-literal form)) 79 | ((string-literal-p form) (compile-string-literal form)) 80 | (t (error "The value ~S is an invalid expression." form)))) 81 | 82 | (defun compile-bool-literal (form) 83 | (compile-bool form)) 84 | 85 | (defun compile-int-literal (form) 86 | (compile-int form)) 87 | 88 | (defun compile-float-literal (form) 89 | (compile-float form)) 90 | 91 | (defun compile-double-literal (form) 92 | (compile-double form)) 93 | 94 | (defun compile-string-literal (form) 95 | (compile-string form)) 96 | 97 | ;;; OpenCL literal 98 | ;;;; 99 | 100 | (defun compile-opencl-literal (form) 101 | (c-macro-name form)) 102 | 103 | ;;; 104 | ;;; Reference 105 | ;;; 106 | 107 | (defun compile-reference (form env) 108 | (cond 109 | ((variable-reference-p form) 110 | (compile-variable-reference form env)) 111 | ((structure-reference-p form) 112 | (compile-structure-reference form env)) 113 | ((array-reference-p form) 114 | (compile-array-reference form env)) 115 | (t (error "The value ~S is an invalid form." form)))) 116 | 117 | 118 | ;;; 119 | ;;; Reference - Variable 120 | ;;; 121 | 122 | (defun compile-variable-reference (form env) 123 | (cond 124 | ((variable-environment-variable-exists-p env form) 125 | (compile-symbol form)) 126 | ((variable-environment-memory-exists-p env form) 127 | (variable-environment-memory-c-name env form)) 128 | (t 129 | (error "The variable ~S not found." form)))) 130 | 131 | ;;; 132 | ;;; Reference - Structure 133 | ;;; 134 | 135 | (defun compile-structure-reference (form env) 136 | (let ((accessor (structure-reference-accessor form)) 137 | (expr (structure-reference-expr form))) 138 | ;; check if the expression part of structure reference has the 139 | ;; same type as accessor's structure 140 | (let ((structure (structure-from-accessor accessor)) 141 | (expr-type (type-of-expression expr env))) 142 | (unless (eq structure expr-type) 143 | (error "The structure reference ~S is invalid." form))) 144 | (let ((accessor1 (structure-accessor-opencl-accessor accessor)) 145 | (expr1 (compile-expression expr env))) 146 | (fmt "~A.~A" expr1 accessor1)))) 147 | 148 | 149 | ;;; 150 | ;;; Reference - Array 151 | ;;; 152 | 153 | (defun compile-array-indices (indices env) 154 | (mapcar #'(lambda (index) 155 | (compile-expression index env)) 156 | indices)) 157 | 158 | (defun compile-array-reference (form env) 159 | (let ((expr (array-reference-expr form)) 160 | (indices (array-reference-indices form))) 161 | ;; check if the expression part of array reference has the same 162 | ;; dimension as the array reference 163 | (let ((expr-type (type-of-expression expr env))) 164 | (unless (= (array-type-dimension expr-type) (length indices)) 165 | (error "The dimension of array reference ~S is invalid." form))) 166 | (let ((expr1 (compile-expression expr env)) 167 | (indices1 (compile-array-indices indices env))) 168 | (fmt "~A~{[~A]~}" expr1 indices1)))) 169 | 170 | 171 | ;;; 172 | ;;; Inline-if 173 | ;;; 174 | 175 | (defun compile-inline-if (form env) 176 | (let ((test-expr (inline-if-test-expression form)) 177 | (then-expr (inline-if-then-expression form)) 178 | (else-expr (inline-if-else-expression form))) 179 | ;; check if the test part of inline-if expression has bool type 180 | (let ((test-type (type-of-expression test-expr env))) 181 | (unless (eq test-type 'bool) 182 | (error "The type of expression ~S is invalid." form))) 183 | ;; check if the then part of inline-of expression has the same 184 | ;; type as the else part of it 185 | (let ((then-type (type-of-expression then-expr env)) 186 | (else-type (type-of-expression else-expr env))) 187 | (unless (eq then-type else-type) 188 | (error "The type of expression ~S is invalid." form))) 189 | (let ((test-expr1 (compile-expression test-expr env)) 190 | (then-expr1 (compile-expression then-expr env)) 191 | (else-expr1 (compile-expression else-expr env))) 192 | (fmt "(~A ? ~A : ~A)" test-expr1 then-expr1 else-expr1)))) 193 | 194 | 195 | ;;; 196 | ;;; Arithmetic operations 197 | ;;; 198 | 199 | (defun compile-arithmetic (form env) 200 | (let ((operator (arithmetic-operator form)) 201 | (operands (arithmetic-operands form))) 202 | (if (<= (length operands) 2) 203 | (compile-function form env) 204 | (let ((operand-first (car operands)) 205 | (operand-second (cadr operands)) 206 | (operand-tail (cddr operands))) 207 | (let ((form1 `(,operator (,operator ,operand-first ,operand-second) 208 | ,@operand-tail))) 209 | (compile-expression form1 env)))))) 210 | 211 | 212 | ;;; 213 | ;;; Function application 214 | ;;; 215 | 216 | (defun type-of-operands (operands env) 217 | (oclcl.lang.compiler.type-of-expression::type-of-operands operands env)) 218 | 219 | (defun compile-operands (operands env) 220 | (mapcar #'(lambda (operand) 221 | (compile-expression operand env)) 222 | operands)) 223 | 224 | (defun compile-function (form env) 225 | (let ((operator (function-operator form))) 226 | (if (function-environment-function-exists-p env operator) 227 | (compile-user-defined-function form env) 228 | (compile-built-in-function form env)))) 229 | 230 | (defun compile-user-defined-function (form env) 231 | (let ((operator (function-operator form)) 232 | (operands (function-operands form))) 233 | ;; check if the operands have the same types as the operator expect 234 | (let ((expected (function-environment-function-argument-types 235 | env operator)) 236 | (actual (type-of-operands operands env))) 237 | (unless (equal expected actual) 238 | (error "The function application ~S is invalid." form))) 239 | (let ((operator1 (function-environment-function-c-name env 240 | operator)) 241 | (operands1 (compile-operands operands env))) 242 | (if operands1 243 | (fmt "~A(~{~A~^, ~})" operator1 operands1) 244 | (fmt "~A()" operator1))))) 245 | 246 | (defun compile-built-in-function (form env) 247 | (let ((operator (function-operator form)) 248 | (operands (function-operands form))) 249 | (let ((operand-types (type-of-operands operands env))) 250 | (if (built-in-function-infix-p operator operand-types) 251 | (compile-built-in-infix-function operator operands operand-types 252 | env) 253 | (compile-built-in-prefix-function operator operands operand-types 254 | env))))) 255 | 256 | (defun compile-built-in-infix-function (operator operands operand-types 257 | env) 258 | (let ((op (built-in-function-c-name operator operand-types)) 259 | (lhe (compile-expression (car operands) env)) 260 | (rhe (compile-expression (cadr operands) env))) 261 | (fmt "(~A ~A ~A)" lhe op rhe))) 262 | 263 | (defun compile-built-in-prefix-function (operator operands operand-types 264 | env) 265 | (let ((operator1 (built-in-function-c-name operator operand-types)) 266 | (operands1 (compile-operands operands env))) 267 | (if operands1 268 | (fmt "~A(~{~A~^, ~})" operator1 operands1) 269 | (fmt "~A()" operator1)))) 270 | 271 | ;;; 272 | ;;; Compile sizeof 273 | ;;; 274 | 275 | (defun compile-sizeof (form env) 276 | (let ((operand (first (sizeof-operand form)))) 277 | (fmt "sizeof(~A)" (if (oclcl-type-p operand) 278 | (opencl-type operand) 279 | (compile-expression operand env))))) -------------------------------------------------------------------------------- /tests/lang/compiler/compile-statement.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.tests.lang.compiler.compile-statement 9 | (:use :cl :rove 10 | :oclcl.tests.utils 11 | :oclcl.lang.util 12 | :oclcl.lang.data 13 | :oclcl.lang.type 14 | :oclcl.lang.syntax 15 | :oclcl.lang.environment 16 | :oclcl.lang.compiler.compile-statement) 17 | (:import-from :oclcl.lang.compiler.compile-statement 18 | :compile-macro 19 | :compile-if 20 | :compile-let 21 | :compile-symbol-macrolet 22 | :compile-do 23 | :compile-with-local-memory 24 | :compile-set 25 | :compile-progn 26 | :compile-return 27 | :compile-function) 28 | (:import-from :serapeum 29 | :fmt)) 30 | (in-package :oclcl.tests.lang.compiler.compile-statement) 31 | 32 | (defun %test-compile-statement (statement-func lisp-code c-code message) 33 | (with-empty-env (env) 34 | (is (apply statement-func (list lisp-code env)) c-code 35 | message))) 36 | 37 | ;;; 38 | ;;; test COMPILE-STATEMENT function 39 | ;;; 40 | 41 | (deftest compile-statement 42 | (flet ((test-statement (lisp-code c-code message) 43 | (%test-compile-statement #'compile-statement lisp-code c-code message))) 44 | (test-statement '(return) (unlines "return;") "return statement") 45 | (test-statement '(+ 1 2) (unlines "(1 + 2);") "arithmetic statement"))) 46 | 47 | 48 | ;;; 49 | ;;; test COMPILE-MACRO function 50 | ;;; 51 | 52 | (deftest compile-macro 53 | (with-empty-env (env) 54 | (setf env (function-environment-add-macro 'alfa '(x) '(`(let ((,x 0)) 55 | (* ,x ,x))) 56 | env)) 57 | (flet ((test-statement (lisp-code c-code message) 58 | (is (compile-macro lisp-code env) c-code message))) 59 | (test-statement '(alfa bravo) (unlines "{" 60 | " int bravo = 0;" 61 | " (bravo * bravo);" 62 | "}") 63 | "macro statement")))) 64 | 65 | 66 | ;;; 67 | ;;; test COMPILE-IF funciton 68 | ;;; 69 | 70 | (deftest compile-if 71 | (defun test-if (lisp-code c-code message) 72 | (%test-compile-statement #'compile-if lisp-code c-code message)) 73 | 74 | (test-if '(if t (return) (return)) 75 | (unlines "if (true)" 76 | "{" 77 | " return;" 78 | "}" 79 | "else" 80 | "{" 81 | " return;" 82 | "}") 83 | "test if else") 84 | 85 | (test-if '(if t (return 0)) 86 | (unlines "if (true)" 87 | "{" 88 | " return 0;" 89 | "}") 90 | "test if") 91 | 92 | (with-empty-env (env) 93 | (let ((lisp-code '(if 1 (return)))) 94 | (ok (signals (compile-if lisp-code env) 'simple-error)) ))) 95 | 96 | 97 | ;;; 98 | ;;; test COMPILE-LET function 99 | ;;; 100 | 101 | (deftest compile-let 102 | (defun test-let (lisp-code c-code message) 103 | (%test-compile-statement #'compile-let lisp-code c-code message)) 104 | 105 | (test-let '(let ((i 0)) 106 | (return)) 107 | (unlines "{" 108 | " int i = 0;" 109 | " return;" 110 | "}") 111 | "basic case 1") 112 | 113 | (with-empty-env (env) 114 | (ok (signals (compile-let '(let (i) (return)) env) 115 | 'simple-error)) 116 | (ok (signals (compile-let '(let ((i)) (return)) env) 117 | 'simple-error)) 118 | (ok (signals (compile-let '(let ((x 1) (y x)) (return y)) env) 119 | 'simple-error)))) 120 | 121 | 122 | ;;; 123 | ;;; test COMPILE-SYMBOL-MACROLET function 124 | ;;; 125 | 126 | (deftest compile-symbol-macrolet 127 | (defun test-symbol-macrolet (lisp-code c-code message) 128 | (%test-compile-statement #'compile-symbol-macrolet lisp-code c-code message)) 129 | 130 | (test-symbol-macrolet '(symbol-macrolet ((x 1)) 131 | (return x)) 132 | (unlines "return 1;") 133 | "basic case 1")) 134 | 135 | 136 | 137 | ;;; 138 | ;;; test COMPILE-DO function 139 | ;;; 140 | 141 | (deftest compile-do 142 | (defun test-do (lisp-code c-code message) 143 | (%test-compile-statement #'compile-do lisp-code c-code message)) 144 | 145 | (test-do '(do ((a 0 (+ a 1)) 146 | (b 0 (+ b 1))) 147 | ((> a 15)) 148 | (return)) 149 | (unlines "for ( int a = 0, int b = 0; ! (a > 15); a = (a + 1), b = (b + 1) )" 150 | "{" 151 | " return;" 152 | "}") 153 | "basic case 1")) 154 | 155 | 156 | ;;; 157 | ;;; test COMPILE-WITH-LOCAL-MEMORY function 158 | ;;; 159 | 160 | (deftest compile-with-local-memory 161 | (defun test-local-memory (lisp-code c-code message) 162 | (%test-compile-statement #'compile-with-local-memory lisp-code c-code message)) 163 | 164 | (test-local-memory '(with-local-memory ((a int 16) 165 | (b float 16 16)) 166 | (return)) 167 | (unlines "{" 168 | " __local int a[16];" 169 | " __local float b[16][16];" 170 | " return;" 171 | "}") 172 | "basic case 1") 173 | 174 | (test-local-memory '(with-local-memory () (return)) 175 | (unlines "{" 176 | " return;" 177 | "}") 178 | "basic case 2") 179 | 180 | (test-local-memory '(with-local-memory ()) 181 | (unlines "{" 182 | "}") 183 | "basic case 3") 184 | 185 | (test-local-memory '(with-local-memory ((a float)) 186 | (return a)) 187 | (unlines "{" 188 | " __local float a;" 189 | " return a;" 190 | "}") 191 | "basic case 4") 192 | 193 | (test-local-memory '(with-local-memory ((a float 16 16)) 194 | (set (aref a 0 0) 1.0f0)) 195 | (unlines "{" 196 | " __local float a[16][16];" 197 | " a[0][0] = 1.0f;" 198 | "}") 199 | "basic case 5") 200 | 201 | (test-local-memory '(with-local-memory ((a float (+ 16 2))) 202 | (set (aref a 0) 1.0f0)) 203 | (unlines "{" 204 | " __local float a[(16 + 2)];" 205 | " a[0] = 1.0f;" 206 | "}") 207 | "store to local memory") 208 | 209 | (test-local-memory '(with-local-memory ((a float (+ 16 2))) 210 | (let ((b 0.0f0)) 211 | (set b (aref a 0)))) 212 | (unlines "{" 213 | " __local float a[(16 + 2)];" 214 | " {" 215 | " float b = 0.0f;" 216 | " b = a[0];" 217 | " }" 218 | "}") 219 | "load from local memory") 220 | 221 | (with-empty-env (env) 222 | (let ((lisp-code '(with-local-memory (a float) 223 | (return)))) 224 | (ok (signals (compile-with-local-memory lisp-code env) 225 | 'simple-error)))) 226 | 227 | (with-empty-env (env) 228 | (let ((lisp-code '(with-local-memory ((a float 16 16)) 229 | (set (aref a 0) 1.0f0)))) 230 | (ok (signals (compile-with-local-memory lisp-code env) 231 | 'simple-error))))) 232 | 233 | 234 | ;;; 235 | ;;; test COMPILE-SET function 236 | ;;; 237 | 238 | (deftest compile-set 239 | (with-empty-env (env) 240 | (setf env (variable-environment-add-variable 'x 'int env)) 241 | (is (compile-set '(set x 1) env) 242 | (unlines "x = 1;") 243 | "basic case 1") 244 | (ok (signals (compile-set '(set x 1.0f0) env) 'simple-error))) 245 | 246 | (testing "literal" 247 | (dolist (type oclcl.lang.type::+scalar-float-types+) 248 | (testing (fmt "type ~A" type) 249 | (with-empty-env (env) 250 | (setf env (variable-environment-add-variable 'x type env)) 251 | (is (compile-set '(set x 1) env) (unlines "x = 1;")))))) 252 | 253 | (testing "variable" 254 | (dolist (type oclcl.lang.type::+scalar-float-types+) 255 | (dolist (right oclcl.lang.type::+scalar-integer-types+) 256 | (testing (fmt "type ~A" type) 257 | (with-empty-env (env) 258 | (setf env (variable-environment-add-variable 'x type env)) 259 | (testing (fmt "type ~A" right) 260 | (setf env (variable-environment-add-variable 'y type env)) 261 | (is (compile-set '(set x y) env) (unlines "x = y;")))))))) 262 | 263 | (with-empty-env (env) 264 | (setf env (variable-environment-add-variable 'x 'int* env)) 265 | (is (compile-set '(set (aref x 0) 1) env) 266 | (unlines "x[0] = 1;") 267 | "basic case 2") 268 | (ok (signals (compile-set '(set (aref x 0) 1.0f0) env) 269 | 'simple-error))) 270 | (with-empty-env (env) 271 | (setf env (variable-environment-add-variable 'x 'float3 env)) 272 | (is (compile-set '(set (float3-x x) 1.0f0) env) 273 | (unlines "x.x = 1.0f;") 274 | "basic case 3") 275 | (ok (compile-set '(set (float3-x x) 1) env)))) 276 | 277 | 278 | ;;; 279 | ;;; test COMPILE-PROGN function 280 | ;;; 281 | 282 | 283 | (deftest compile-progn 284 | (with-empty-env (env) 285 | (is (compile-progn '(progn) env) "") 286 | (is (compile-progn '(progn (return)) env) (unlines "return;")))) 287 | 288 | ;;; 289 | ;;; test COMPILE-RETURN function 290 | ;;; 291 | 292 | (deftest compile-return 293 | (with-empty-env (env) 294 | (is (compile-return '(return) env) (unlines "return;")))) 295 | 296 | ;;; 297 | ;;; test COMPILE-FUNCTION function 298 | ;;; 299 | 300 | (deftest compile-function 301 | (with-empty-env (env) 302 | (setf env (function-environment-add-function 'alfa 'int '(int) env)) 303 | (is (compile-function '(alfa 1) env) 304 | (unlines "oclcl_tests_lang_compiler_compile_statement_alfa(1);")))) -------------------------------------------------------------------------------- /src/lang/compiler/compile-statement.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.lang.compiler.compile-statement 9 | (:use :cl 10 | :oclcl.lang.util 11 | :oclcl.lang.type 12 | :oclcl.lang.syntax 13 | :oclcl.lang.environment 14 | :oclcl.lang.compiler.compile-data 15 | :oclcl.lang.compiler.compile-type 16 | :oclcl.lang.compiler.type-of-expression 17 | :oclcl.lang.compiler.compile-expression) 18 | (:import-from #:serapeum 19 | #:fmt) 20 | (:export :compile-statement)) 21 | (in-package :oclcl.lang.compiler.compile-statement) 22 | 23 | 24 | ;;; 25 | ;;; Compile statement 26 | ;;; 27 | 28 | (defun compile-statement (form env) 29 | (cond 30 | ((%macro-p form env) (compile-macro form env)) 31 | ((if-p form) (compile-if form env)) 32 | ((let-p form) (compile-let form env)) 33 | ((symbol-macrolet-p form) (compile-symbol-macrolet form env)) 34 | ((do-p form) (compile-do form env)) 35 | ((with-local-memory-p form) 36 | (compile-with-local-memory form env)) 37 | ((set-p form) (compile-set form env)) 38 | ((progn-p form) (compile-progn form env)) 39 | ((return-p form) (compile-return form env)) 40 | ((declare-p form) (compile-declare form env)) 41 | ((function-p form) (compile-function form env)) 42 | (t (error "The value ~S is an invalid statement." form)))) 43 | 44 | 45 | ;;; 46 | ;;; Macro 47 | ;;; 48 | 49 | (defun %macro-p (form env) 50 | (oclcl.lang.compiler.compile-expression::%macro-p form env)) 51 | 52 | (defun compile-macro (form env) 53 | (let ((operator (macro-operator form)) 54 | (operands (macro-operands form))) 55 | (let ((expander (function-environment-macro-expander env operator))) 56 | (let ((form1 (funcall expander operands))) 57 | (compile-statement form1 env))))) 58 | 59 | 60 | ;;; 61 | ;;; If statement 62 | ;;; 63 | 64 | (defun compile-if (form env) 65 | (let ((test-expr (if-test-expression form)) 66 | (then-stmt (if-then-statement form)) 67 | (else-stmt (if-else-statement form))) 68 | ;; check if the test part of inline-if expression has bool type 69 | (let ((test-type (type-of-expression test-expr env))) 70 | (unless (eq test-type 'bool) 71 | (error "The type of statement ~S is invalid." form))) 72 | (let* ((compiled-test (compile-expression test-expr env)) 73 | (compiled-then (compile-statement then-stmt env)) 74 | (compiled-else (when else-stmt 75 | (compile-statement else-stmt env))) 76 | (final-test (if (and (plusp (length compiled-test)) 77 | (char/= #\( (char compiled-test 0))) 78 | (fmt "(~A)" compiled-test) 79 | compiled-test)) 80 | (indented-then (indent 2 compiled-then)) 81 | (indented-else (when compiled-else 82 | (indent 2 compiled-else)))) 83 | (fmt "if ~A~%{~%~A}~@[~%else~%{~%~A}~]~%" 84 | final-test 85 | indented-then 86 | indented-else)))) 87 | 88 | 89 | ;;; 90 | ;;; Let statement 91 | ;;; 92 | 93 | (defun env-add-let-bindings (env bindings) 94 | (flet ((aux (env0 binding) 95 | (let* ((var (let-binding-var binding)) 96 | (expr (let-binding-expr binding)) 97 | (type (type-of-expression expr env))) 98 | (variable-environment-add-variable var type env0)))) 99 | (reduce #'aux bindings :initial-value env))) 100 | 101 | (defun compile-let-bindings (bindings env) 102 | (flet ((aux (binding) 103 | (let* ((var (let-binding-var binding)) 104 | (expr (let-binding-expr binding)) 105 | (type (type-of-expression expr env))) 106 | (let ((var1 (compile-symbol var)) 107 | (expr1 (compile-expression expr env)) 108 | (type1 (compile-type type))) 109 | (fmt "~A ~A = ~A;~%" type1 var1 expr1))))) 110 | (fmt "~{~A~}" (mapcar #'aux bindings)))) 111 | 112 | (defun compile-statements-in-block (statements env) 113 | (compile-statement `(progn ,@statements) env)) 114 | 115 | (defun compile-let (form env) 116 | (let* ((bindings (let-bindings form)) 117 | (statements (let-statements form)) 118 | (env1 (env-add-let-bindings env bindings)) 119 | (bindings1 (compile-let-bindings bindings env)) 120 | (statements1 (compile-statements-in-block statements env1)) 121 | (bindings2 (indent 2 bindings1)) 122 | (statements2 (indent 2 statements1))) 123 | (fmt "{~%~A~A}~%" bindings2 statements2))) 124 | 125 | 126 | ;;; 127 | ;;; Symbol-macrolet statement 128 | ;;; 129 | 130 | (defun env-add-symbol-macrolet-bindings (env bindings) 131 | (flet ((aux (env0 binding) 132 | (let* ((symbol (symbol-macrolet-binding-symbol binding)) 133 | (expansion (symbol-macrolet-binding-expansion binding))) 134 | (variable-environment-add-symbol-macro symbol expansion 135 | env0)))) 136 | (reduce #'aux bindings :initial-value env))) 137 | 138 | (defun compile-symbol-macrolet (form env) 139 | (let ((bindings (symbol-macrolet-bindings form)) 140 | (statements (symbol-macrolet-statements form))) 141 | (let ((env1 (env-add-symbol-macrolet-bindings env bindings))) 142 | (let ((statements1 (compile-statements-in-block statements env1))) 143 | (fmt "~a" statements1))))) 144 | 145 | 146 | ;;; 147 | ;;; Do statement 148 | ;;; 149 | 150 | (defun env-add-do-bindings (env bindings) 151 | (flet ((aux (env0 binding) 152 | (let* ((var (do-binding-var binding)) 153 | (init (do-binding-init binding)) 154 | (type (type-of-expression init env))) 155 | (variable-environment-add-variable var type env0)))) 156 | (reduce #'aux bindings :initial-value env))) 157 | 158 | (defun compile-do-init-part (bindings env) 159 | (flet ((aux (binding) 160 | (let* ((var (do-binding-var binding)) 161 | (init (do-binding-init binding)) 162 | (type (type-of-expression init env))) 163 | (let ((var1 (compile-symbol var)) 164 | (init1 (compile-expression init env)) 165 | (type1 (compile-type type))) 166 | (fmt "~A ~A = ~A" type1 var1 init1))))) 167 | (fmt "~{~A~^, ~}" (mapcar #'aux bindings)))) 168 | 169 | (defun compile-do-test-part (end-test env) 170 | (let ((end-test1 (compile-expression end-test env))) 171 | (fmt "! ~A" end-test1))) 172 | 173 | (defun compile-do-step-part (bindings env) 174 | (flet ((aux (binding) 175 | (let ((var (do-binding-var binding)) 176 | (step (do-binding-step binding))) 177 | (let ((var1 (compile-symbol var)) 178 | (step1 (compile-expression step env))) 179 | (fmt "~A = ~A" var1 step1))))) 180 | (fmt "~{~A~^, ~}" (mapcar #'aux bindings)))) 181 | 182 | (defun compile-do (form env) 183 | (let* ((bindings (do-bindings form)) 184 | (end-test (do-end-test form)) 185 | (statements (do-statements form)) 186 | (env1 (env-add-do-bindings env bindings)) 187 | (init-part (compile-do-init-part bindings env)) 188 | (test-part (compile-do-test-part end-test env1)) 189 | (step-part (compile-do-step-part bindings env1)) 190 | (statements1 (compile-statements-in-block statements env1)) 191 | (statements2 (indent 2 statements1))) 192 | (fmt "for ( ~A; ~A; ~A )~%{~%~A}~%" 193 | init-part test-part step-part statements2))) 194 | 195 | 196 | ;;; 197 | ;;; With-local-memory statement 198 | ;;; 199 | 200 | (defun env-add-with-local-memory-specs (env specs) 201 | (flet ((aux (env0 spec) 202 | (let* ((var (with-local-memory-spec-var spec)) 203 | (type (with-local-memory-spec-type spec)) 204 | (dims (length (with-local-memory-spec-dimensions spec)))) 205 | (let ((type1 (array-type type dims))) 206 | (variable-environment-add-variable var type1 env0))))) 207 | (reduce #'aux specs :initial-value env))) 208 | 209 | (defun compile-with-local-memory-spec-dimensions (dims env) 210 | (flet ((aux (dim) 211 | (compile-expression dim env))) 212 | (mapcar #'aux dims))) 213 | 214 | (defun compile-with-local-memory-specs (specs env) 215 | (flet ((aux (spec) 216 | (let ((var (with-local-memory-spec-var spec)) 217 | (type (with-local-memory-spec-type spec)) 218 | (dims (with-local-memory-spec-dimensions spec))) 219 | (let ((var1 (compile-symbol var)) 220 | (type1 (compile-type type)) 221 | (dims1 (compile-with-local-memory-spec-dimensions 222 | dims env))) 223 | ;; OpenCL v1.2 dr19: 6.5 Address Spece Qualifiers 224 | (fmt "__local ~A ~A~{[~A]~};~%" type1 var1 dims1))))) 225 | (fmt "~{~A~}" (mapcar #'aux specs)))) 226 | 227 | (defun compile-with-local-memory (form env) 228 | (let ((specs (with-local-memory-specs form)) 229 | (statements (with-local-memory-statements form))) 230 | (let ((env1 (env-add-with-local-memory-specs env specs))) 231 | (let ((specs1 (compile-with-local-memory-specs specs env)) 232 | (statements1 (compile-statements-in-block statements env1))) 233 | (let ((specs2 (indent 2 specs1)) 234 | (statements2 (indent 2 statements1))) 235 | (fmt "{~%~A~A}~%" specs2 statements2)))))) 236 | 237 | 238 | ;;; 239 | ;;; Set statement 240 | ;;; 241 | 242 | (defun compile-set (form env) 243 | (let ((reference (set-reference form)) 244 | (expr (set-expression form))) 245 | ;; check if the reference part of set statement has the same type 246 | ;; as the expression part of that 247 | (let ((ref-type (type-of-expression reference env)) 248 | (expr-type (type-of-expression expr env))) 249 | (unless (or (eq ref-type expr-type) 250 | (and (scalar-float-type-p ref-type) 251 | (scalar-integer-type-p expr-type))) 252 | (error "The type of statement ~S is type mismatch (~S and ~S)." 253 | form ref-type expr-type))) 254 | (let ((reference1 (compile-expression reference env)) 255 | (expr1 (compile-expression expr env))) 256 | (fmt "~A = ~A;~%" reference1 expr1)))) 257 | 258 | 259 | ;;; 260 | ;;; Progn statement 261 | ;;; 262 | 263 | (defun compile-progn (form env) 264 | (flet ((aux (statement) 265 | (compile-statement statement env))) 266 | (let ((statements (progn-statements form))) 267 | (let ((statements1 (mapcar #'aux statements))) 268 | (fmt "~{~A~}" statements1))))) 269 | 270 | 271 | ;;; 272 | ;;; Return statement 273 | ;;; 274 | 275 | (defun compile-return (form env) 276 | (let ((expr (return-expr form))) 277 | (if expr 278 | (let ((expr1 (compile-expression expr env))) 279 | (fmt "return ~A;~%" expr1)) 280 | (fmt "return;~%")))) 281 | 282 | 283 | ;;; 284 | ;;; Function application 285 | ;;; 286 | 287 | (defun compile-function (form env) 288 | (let ((code (oclcl.lang.compiler.compile-expression::compile-function 289 | form env))) 290 | (fmt "~A;~%" code))) 291 | 292 | 293 | ;;; 294 | ;;; Compiler directives 295 | ;;; 296 | 297 | (defun compile-declare (form env) 298 | (declare (ignore env)) 299 | (fmt "#~{~A~^ ~}~%" (cdr form))) -------------------------------------------------------------------------------- /src/lang/environment.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015-2025 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.lang.environment 9 | (:use :cl 10 | :oclcl.lang.util 11 | :oclcl.lang.data 12 | :oclcl.lang.type) 13 | (:export ;; Environment 14 | :environment 15 | :make-environment 16 | :copy-environment 17 | :environment-p 18 | :environment-var-env 19 | :environment-func-env 20 | :environment-def-env 21 | :empty-environment 22 | ;; Variable environment - Variable 23 | :variable-environment-add-variable 24 | :variable-environment-variable-exists-p 25 | :variable-environment-variable-name 26 | :variable-environment-variable-type 27 | ;; Variable environment - Symbol macro 28 | :variable-environment-add-symbol-macro 29 | :variable-environment-symbol-macro-exists-p 30 | :variable-environment-symbol-macro-name 31 | :variable-environment-symbol-macro-expansion 32 | ;; Function environment - Function 33 | :function-environment-add-function 34 | :function-environment-function-exists-p 35 | :function-environment-function-name 36 | :function-environment-function-c-name 37 | :function-environment-function-return-type 38 | :function-environment-function-argument-types 39 | ;; Variable environment - Memory 40 | :variable-environment-add-memory 41 | :variable-environment-memory-exists-p 42 | :variable-environment-memory-name 43 | :variable-environment-memory-c-name 44 | :variable-environment-memory-type 45 | :variable-environment-memory-expression 46 | ;; Function environment - Macro 47 | :function-environment-add-macro 48 | :function-environment-macro-exists-p 49 | :function-environment-macro-name 50 | :function-environment-macro-expander 51 | ;; Define environment - Define 52 | :define-environment-add-define 53 | :define-environment-define-exists-p 54 | :define-environment-define-name 55 | :define-environment-define-c-name 56 | :define-environment-define-expression) 57 | (:shadow :variable) 58 | (:import-from :alexandria 59 | :with-gensyms)) 60 | (in-package :oclcl.lang.environment) 61 | 62 | 63 | ;;; 64 | ;;; Environment 65 | ;;; 66 | 67 | (defstruct environment 68 | (var-env nil :type list) 69 | (func-env nil :type list) 70 | (def-env nil :type list)) 71 | 72 | (defun empty-environment () 73 | (make-environment)) 74 | 75 | (defun copy-env-with-var-env (env new-var-env) 76 | (make-environment :var-env new-var-env 77 | :func-env (environment-func-env env) 78 | :def-env (environment-def-env env))) 79 | 80 | (defun copy-env-with-func-env (env new-func-env) 81 | (make-environment :var-env (environment-var-env env) 82 | :func-env new-func-env 83 | :def-env (environment-def-env env))) 84 | 85 | (defun copy-env-with-def-env (env new-def-env) 86 | (make-environment :var-env (environment-var-env env) 87 | :func-env (environment-func-env env) 88 | :def-env new-def-env)) 89 | 90 | 91 | ;;; 92 | ;;; Variable environment - Variable 93 | ;;; 94 | 95 | (defun variable-environment-add-variable (name type env) 96 | (copy-env-with-var-env 97 | env 98 | (acons name (make-variable name type) (environment-var-env env)))) 99 | 100 | (defun variable-environment-variable-exists-p (env name) 101 | (variable-p (cdr (assoc name (environment-var-env env))))) 102 | 103 | (defun %lookup-variable (env name) 104 | (unless (variable-environment-variable-exists-p env name) 105 | (error "The variable ~S not found." name)) 106 | (cdr (assoc name (environment-var-env env)))) 107 | 108 | (defun variable-environment-variable-name (env name) 109 | (variable-name (%lookup-variable env name))) 110 | 111 | (defun variable-environment-variable-type (env name) 112 | (variable-type (%lookup-variable env name))) 113 | 114 | 115 | ;;; 116 | ;;; Variable environment - Symbol macro 117 | ;;; 118 | 119 | (defun variable-environment-add-symbol-macro (name expansion env) 120 | (copy-env-with-var-env 121 | env 122 | (acons name (make-symbol-macro name expansion) (environment-var-env env)))) 123 | 124 | (defun variable-environment-symbol-macro-exists-p (env name) 125 | (symbol-macro-p (cdr (assoc name (environment-var-env env))))) 126 | 127 | (defun %lookup-symbol-macro (env name) 128 | (unless (variable-environment-symbol-macro-exists-p env name) 129 | (error "The symbol macro ~S not found." name)) 130 | (cdr (assoc name (environment-var-env env)))) 131 | 132 | (defun variable-environment-symbol-macro-name (env name) 133 | (symbol-macro-name (%lookup-symbol-macro env name))) 134 | 135 | (defun variable-environment-symbol-macro-expansion (env name) 136 | (symbol-macro-expansion (%lookup-symbol-macro env name))) 137 | 138 | ;;; Variable environment - Memory 139 | ;;; 140 | 141 | (defun variable-environment-add-memory (name type expression env) 142 | (copy-env-with-var-env 143 | env 144 | (acons name (make-memory name type expression) (environment-var-env env)))) 145 | 146 | (defun variable-environment-memory-exists-p (env name) 147 | (check-type name oclcl-symbol) 148 | (memory-p (cdr (assoc name (environment-var-env env))))) 149 | 150 | (defun %lookup-memory (env name) 151 | (unless (variable-environment-memory-exists-p env name) 152 | (error "The variable ~S not found." name)) 153 | (cdr (assoc name (environment-var-env env)))) 154 | 155 | (defun variable-environment-memory-name (env name) 156 | (memory-name (%lookup-memory env name))) 157 | 158 | (defun variable-environment-memory-c-name (env name) 159 | (memory-c-name (%lookup-memory env name))) 160 | 161 | (defun variable-environment-memory-type (env name) 162 | (memory-type (%lookup-memory env name))) 163 | 164 | (defun variable-environment-memory-expression (env name) 165 | (memory-expression (%lookup-memory env name))) 166 | 167 | 168 | ;;; 169 | ;;; Function environment - Function 170 | ;;; 171 | 172 | (defun function-environment-add-function (name return-type argument-types env) 173 | (copy-env-with-func-env 174 | env 175 | (acons name (make-function name return-type argument-types) (environment-func-env env)))) 176 | 177 | (defun function-environment-function-exists-p (env name) 178 | (function-p (cdr (assoc name (environment-func-env env))))) 179 | 180 | (defun %lookup-function (env name) 181 | (unless (function-environment-function-exists-p env name) 182 | (error "The function ~S is undefined." name)) 183 | (cdr (assoc name (environment-func-env env)))) 184 | 185 | (defun function-environment-function-name (env name) 186 | (function-name (%lookup-function env name))) 187 | 188 | (defun function-environment-function-c-name (env name) 189 | (function-c-name (%lookup-function env name))) 190 | 191 | (defun function-environment-function-return-type (env name) 192 | (function-return-type (%lookup-function env name))) 193 | 194 | (defun function-environment-function-argument-types (env name) 195 | (function-argument-types (%lookup-function env name))) 196 | 197 | 198 | ;;; 199 | ;;; Function environment - Macro 200 | ;;; 201 | 202 | (defun function-environment-add-macro (name arguments body env) 203 | (copy-env-with-func-env 204 | env 205 | (acons name (make-macro name arguments body) (environment-func-env env)))) 206 | 207 | (defun function-environment-macro-exists-p (env name) 208 | (macro-p (cdr (assoc name (environment-func-env env))))) 209 | 210 | (defun %lookup-macro (env name) 211 | (unless (function-environment-macro-exists-p env name) 212 | (error "The macro ~S is undefined." name)) 213 | (cdr (assoc name (environment-func-env env)))) 214 | 215 | (defun function-environment-macro-name (env name) 216 | (macro-name (%lookup-macro env name))) 217 | 218 | (defun function-environment-macro-expander (env name) 219 | (macro-expander (%lookup-macro env name))) 220 | 221 | 222 | ;;; 223 | ;;; Variable 224 | ;;; 225 | 226 | (defstruct (variable (:constructor %make-variable)) 227 | (name :name :read-only t) 228 | (type :type :read-only t)) 229 | 230 | (defun make-variable (name type) 231 | (unless (oclcl-symbol-p name) 232 | (error 'type-error :datum name :expected-type 'oclcl-symbol)) 233 | (unless (oclcl-type-p type) 234 | (error 'type-error :datum type :expected-type 'oclcl-type)) 235 | (%make-variable :name name :type type)) 236 | 237 | 238 | ;;; 239 | ;;; Symbol macro 240 | ;;; 241 | 242 | (defstruct (symbol-macro (:constructor %make-symbol-macro)) 243 | (name :name :read-only t) 244 | (expansion :expansion :read-only t)) 245 | 246 | (defun make-symbol-macro (name expansion) 247 | (unless (oclcl-symbol-p name) 248 | (error 'type-error :datum name :expected-type 'oclcl-symbol)) 249 | (%make-symbol-macro :name name :expansion expansion)) 250 | 251 | 252 | ;;; Memory 253 | ;;; 254 | 255 | (defstruct (memory (:constructor %make-memory)) 256 | (name :name :read-only t) 257 | (type :type :read-only t) 258 | (expression :expression :read-only t)) 259 | 260 | (defun make-memory (name type expression) 261 | (check-type name oclcl-symbol) 262 | (check-type type oclcl-type) 263 | (%make-memory :name name :type type :expression expression)) 264 | 265 | (defun memory-c-name (memory) 266 | (c-identifier (memory-name memory) t)) 267 | 268 | ;;; 269 | ;;; Function 270 | ;;; 271 | 272 | ;; use name begining with '%' to avoid package locking 273 | (defstruct (%function (:constructor %make-function) 274 | (:conc-name function-) 275 | (:predicate function-p)) 276 | (name :name :read-only t) 277 | (return-type :return-type :read-only t) 278 | (argument-types :argument-types :read-only t)) 279 | 280 | (defun make-function (name return-type argument-types) 281 | (unless (oclcl-symbol-p name) 282 | (error 'type-error :datum name :expected-type 'oclcl-symbol)) 283 | (unless (oclcl-type-p return-type) 284 | (error 'type-error :datum return-type :expected-type 'oclcl-type)) 285 | (dolist (argument-type argument-types) 286 | (unless (oclcl-type-p argument-type) 287 | (error 'type-error :datum argument-type 288 | :expected-type 'oclcl-type))) 289 | (%make-function :name name 290 | :return-type return-type 291 | :argument-types argument-types)) 292 | 293 | (defun function-c-name (function) 294 | (c-identifier (function-name function) t)) 295 | 296 | 297 | ;;; 298 | ;;; Macro 299 | ;;; 300 | 301 | (defstruct (macro (:constructor %make-macro)) 302 | (name :name :read-only t) 303 | (arguments :arguments :read-only t) 304 | (body :body :read-only t)) 305 | 306 | (defun make-macro (name arguments body) 307 | (unless (oclcl-symbol-p name) 308 | (error 'type-error :datum name :expected-type 'oclcl-symbol)) 309 | (unless (listp arguments) 310 | (error 'type-error :datum arguments :expected-type 'list)) 311 | (unless (listp body) 312 | (error 'type-error :datum body :expected-type 'list)) 313 | (%make-macro :name name :arguments arguments :body body)) 314 | 315 | (defun macro-expander (macro) 316 | (let ((arguments (macro-arguments macro)) 317 | (body (macro-body macro))) 318 | (with-gensyms (arguments1) 319 | (eval `#'(lambda (,arguments1) 320 | (destructuring-bind ,arguments ,arguments1 321 | ,@body)))))) 322 | 323 | ;;; 324 | ;;; Define environment - Define 325 | ;;; 326 | 327 | (defun define-environment-add-define (name expression env) 328 | (copy-env-with-def-env 329 | env 330 | (acons name (make-define name expression) (environment-def-env env)))) 331 | 332 | (defun define-environment-define-exists-p (env name) 333 | (check-type name oclcl-symbol) 334 | (define-p (cdr (assoc name (environment-def-env env))))) 335 | 336 | (defun %lookup-define (env name) 337 | (unless (define-environment-define-exists-p env name) 338 | (error "The define ~S not found." name)) 339 | (cdr (assoc name (environment-def-env env)))) 340 | 341 | (defun define-environment-define-name (env name) 342 | (define-name (%lookup-define env name))) 343 | 344 | (defun define-environment-define-c-name (env name) 345 | (define-c-name (%lookup-define env name))) 346 | 347 | (defun define-environment-define-expression (env name) 348 | (define-expression (%lookup-define env name))) 349 | 350 | ;;; Define 351 | ;;; 352 | 353 | (defstruct (define (:constructor %make-define)) 354 | (name :name :read-only t) 355 | (expression :expression :read-only t)) 356 | 357 | (defun make-define (name expression) 358 | (check-type name oclcl-symbol) 359 | (%make-define :name name :expression expression)) 360 | 361 | (defun define-c-name (define) 362 | (c-identifier (define-name define) t)) -------------------------------------------------------------------------------- /src/lang/syntax.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of oclcl project. 3 | Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com) 4 | 2015 gos-k (mag4.elan@gmail.com) 5 | |# 6 | 7 | (in-package :cl-user) 8 | (defpackage oclcl.lang.syntax 9 | (:use :cl 10 | :oclcl.lang.data 11 | :oclcl.lang.type) 12 | (:export ;; Symbol macro 13 | :symbol-macro-p 14 | ;; Macro 15 | :macro-p 16 | :macro-operator 17 | :macro-operands 18 | ;; Literal 19 | :literal-p 20 | :bool-literal-p 21 | :int-literal-p 22 | :float-literal-p 23 | :double-literal-p 24 | :string-literal-p 25 | ;; OpenCL literal 26 | :opencl-literal-p 27 | :cl-mem-fence-flags-literal-p 28 | :clk-local-mem-fence 29 | :clk-global-mem-fence 30 | ;; Reference 31 | :reference-p 32 | ;; Reference - Variable 33 | :variable-reference-p 34 | ;; Reference - Structure 35 | :structure-reference-p 36 | :structure-reference-accessor 37 | :structure-reference-expr 38 | ;; Reference - Array 39 | :array-reference-p 40 | :array-reference-expr 41 | :array-reference-indices 42 | ;; Inline-if 43 | :inline-if-p 44 | :inline-if-test-expression 45 | :inline-if-then-expression 46 | :inline-if-else-expression 47 | ;; Arithmetic 48 | :arithmetic-p 49 | :arithmetic-operator 50 | :arithmetic-operands 51 | ;; Function application 52 | :function-p 53 | :function-operator 54 | :function-operands 55 | ;; If statement 56 | :if-p 57 | :if-test-expression 58 | :if-then-statement 59 | :if-else-statement 60 | ;; Let statement 61 | :let-p 62 | :let-bindings 63 | :let-statements 64 | ;; Let statement - binding 65 | :let-binding-p 66 | :let-binding-var 67 | :let-binding-expr 68 | ;; Symbol-macrolet statement 69 | :symbol-macrolet-p 70 | :symbol-macrolet-bindings 71 | :symbol-macrolet-statements 72 | ;; Symbol-macrolet statement - binding 73 | :symbol-macrolet-binding-p 74 | :symbol-macrolet-binding-symbol 75 | :symbol-macrolet-binding-expansion 76 | ;; Do statement 77 | :do-p 78 | :do-bindings 79 | :do-end-test 80 | :do-statements 81 | ;; Do statement - binding 82 | :do-binding-p 83 | :do-binding-var 84 | :do-binding-init 85 | :do-binding-step 86 | ;; With-local-memory statement 87 | :with-local-memory 88 | :with-local-memory-p 89 | :with-local-memory-specs 90 | :with-local-memory-statements 91 | ;; With-local-memory statement - spec 92 | :with-local-memory-spec-p 93 | :with-local-memory-spec-var 94 | :with-local-memory-spec-type 95 | :with-local-memory-spec-dimensions 96 | ;; Set statement 97 | :set 98 | :set-p 99 | :set-reference 100 | :set-expression 101 | ;; Progn statement 102 | :progn-p 103 | :progn-statements 104 | ;; Return statement 105 | :return-p 106 | :return-expr 107 | ;; Argument 108 | :argument 109 | :argument-p 110 | :argument-var 111 | :argument-type 112 | ;; Compiler directive 113 | :declare-p 114 | ;; sizeof 115 | :sizeof 116 | :sizeof-p 117 | :sizeof-operand)) 118 | (in-package :oclcl.lang.syntax) 119 | 120 | 121 | ;;; 122 | ;;; Symbol macro 123 | ;;; 124 | 125 | (defun symbol-macro-p (form) 126 | (oclcl-symbol-p form)) 127 | 128 | 129 | ;;; 130 | ;;; Macro 131 | ;;; 132 | 133 | (defun macro-p (form) 134 | (cl-pattern:match form 135 | ((name . _) (oclcl-symbol-p name)) 136 | (_ nil))) 137 | 138 | (defun macro-operator (form) 139 | (unless (macro-p form) 140 | (error "The value ~S is an invalid form." form)) 141 | (car form)) 142 | 143 | (defun macro-operands (form) 144 | (unless (macro-p form) 145 | (error "The value ~S is an invalid form." form)) 146 | (cdr form)) 147 | 148 | 149 | ;;; 150 | ;;; Literal 151 | ;;; 152 | 153 | (defun literal-p (form) 154 | (or (bool-literal-p form) 155 | (int-literal-p form) 156 | (float-literal-p form) 157 | (double-literal-p form) 158 | (string-literal-p form))) 159 | 160 | (defun bool-literal-p (form) 161 | (oclcl-bool-p form)) 162 | 163 | (defun int-literal-p (form) 164 | (oclcl-int-p form)) 165 | 166 | (defun float-literal-p (form) 167 | (oclcl-float-p form)) 168 | 169 | (defun double-literal-p (form) 170 | (oclcl-double-p form)) 171 | 172 | (defun string-literal-p (form) 173 | (oclcl-string-p form)) 174 | 175 | ;;; OpenCL literal 176 | ;;; 177 | 178 | (defun opencl-literal-p (form) 179 | (or (cl-mem-fence-flags-literal-p form))) 180 | 181 | (defun cl-mem-fence-flags-literal-p (form) 182 | (and (find form '(:clk-local-mem-fence 183 | :clk-global-mem-fence)) 184 | t)) 185 | 186 | ;;; 187 | ;;; Reference 188 | ;;; 189 | 190 | (defun reference-p (form) 191 | (or (variable-reference-p form) 192 | (structure-reference-p form) 193 | (array-reference-p form))) 194 | 195 | 196 | ;;; 197 | ;;; Reference - Variable 198 | ;;; 199 | 200 | (defun variable-reference-p (form) 201 | (oclcl-symbol-p form)) 202 | 203 | 204 | ;;; 205 | ;;; Reference - Structure 206 | ;;; 207 | 208 | (defun structure-reference-p (form) 209 | (cl-pattern:match form 210 | ((accessor _) (structure-accessor-p accessor)) 211 | (_ nil))) 212 | 213 | (defun structure-reference-accessor (form) 214 | (unless (structure-reference-p form) 215 | (error "The form ~S is invalid." form)) 216 | (car form)) 217 | 218 | (defun structure-reference-expr (form) 219 | (unless (structure-reference-p form) 220 | (error "The form ~S is invalid." form)) 221 | (cadr form)) 222 | 223 | 224 | ;;; 225 | ;;; Reference - Array 226 | ;;; 227 | 228 | (defun array-reference-p (form) 229 | (cl-pattern:match form 230 | (('aref . _) t) 231 | (_ nil))) 232 | 233 | (defun array-reference-expr (form) 234 | (cl-pattern:match form 235 | (('aref expr _ . _) expr) 236 | (('aref . _) (error "The expression ~S is malformed." form)) 237 | (_ (error "The value ~S is an invalid expression." form)))) 238 | 239 | (defun array-reference-indices (form) 240 | (cl-pattern:match form 241 | (('aref _ . indices) (or indices 242 | (error "The expression ~S is malformed." form))) 243 | (('aref) (error "The expression ~S is malformed." form)) 244 | (_ (error "The value ~S is an invalid expression." form)))) 245 | 246 | 247 | ;;; 248 | ;;; Inline-if 249 | ;;; 250 | 251 | (defun inline-if-p (form) 252 | (cl-pattern:match form 253 | (('if . _) t) 254 | (_ nil))) 255 | 256 | (defun inline-if-test-expression (form) 257 | (cl-pattern:match form 258 | (('if test-expr _ _) test-expr) 259 | (('if . _) (error "The expression ~S is malformed." form)) 260 | (_ (error "The value ~S is an invalid expression." form)))) 261 | 262 | (defun inline-if-then-expression (form) 263 | (cl-pattern:match form 264 | (('if _ then-expr _) then-expr) 265 | (('if . _) (error "The expression ~S is malformed." form)) 266 | (_ (error "The value ~S is an invalid expression." form)))) 267 | 268 | (defun inline-if-else-expression (form) 269 | (cl-pattern:match form 270 | (('if _ _ else-expr) else-expr) 271 | (('if . _) (error "The expression ~S is malformed." form)) 272 | (_ (error "The value ~S is an invalid expression." form)))) 273 | 274 | 275 | ;;; 276 | ;;; Arithmetic 277 | ;;; 278 | 279 | (defparameter +arithmetic-operators+ 280 | '(+ - * / mod)) 281 | 282 | (defun arithmetic-p (form) 283 | (cl-pattern:match form 284 | ((name . _) (and (member name +arithmetic-operators+) 285 | t)) 286 | (_ nil))) 287 | 288 | (defun arithmetic-operator (form) 289 | (unless (arithmetic-p form) 290 | (error "The form ~S is invalid." form)) 291 | (car form)) 292 | 293 | (defun arithmetic-operands (form) 294 | (unless (arithmetic-p form) 295 | (error "The form ~S is invalid." form)) 296 | (cdr form)) 297 | 298 | 299 | ;;; 300 | ;;; Function appication 301 | ;;; 302 | 303 | (defun function-p (form) 304 | (cl-pattern:match form 305 | ((name . _) (oclcl-symbol-p name)) 306 | (_ nil))) 307 | 308 | (defun function-operator (form) 309 | (unless (function-p form) 310 | (error "The form ~S is invalid." form)) 311 | (car form)) 312 | 313 | (defun function-operands (form) 314 | (unless (function-p form) 315 | (error "The form ~S is invalid." form)) 316 | (cdr form)) 317 | 318 | 319 | ;;; 320 | ;;; If statement 321 | ;;; 322 | 323 | (defun if-p (form) 324 | (inline-if-p form)) 325 | 326 | (defun if-test-expression (form) 327 | (cl-pattern:match form 328 | (('if _ _ _ _ . _) (error "The statement ~S is malformed." form)) 329 | (('if test-expr _ . _) test-expr) 330 | (('if . _) (error "The statement ~S is malformed." form)) 331 | (_ (error "The value ~S is an invalid statement." form)))) 332 | 333 | (defun if-then-statement (form) 334 | (cl-pattern:match form 335 | (('if _ _ _ _ . _) (error "The statement ~S is malformed." form)) 336 | (('if _ then-stmt . _) then-stmt) 337 | (('if . _) (error "The statement ~S is malformed." form)) 338 | (_ (error "The value ~S is an invalid statement." form)))) 339 | 340 | (defun if-else-statement (form) 341 | (cl-pattern:match form 342 | (('if _ _ _ _ . _) (error "The statement ~S is malformed." form)) 343 | (('if _ _ else-stmt) else-stmt) 344 | (('if _ _) nil) 345 | (('if . _) (error "The statement ~S is malformed." form)) 346 | (_ (error "The value ~S is an invalid statement." form)))) 347 | 348 | 349 | ;;; 350 | ;;; Let statement 351 | ;;; 352 | 353 | (defun let-p (form) 354 | (cl-pattern:match form 355 | (('let . _) t) 356 | (_ nil))) 357 | 358 | (defun let-bindings (form) 359 | (cl-pattern:match form 360 | (('let bindings . _) 361 | (if (every #'let-binding-p bindings) 362 | bindings 363 | (error "The statement ~S is malformed." form))) 364 | (('let . _) (error "The statement ~S is malformed." form)) 365 | (_ (error "The value ~S is an invalid statement." form)))) 366 | 367 | (defun let-statements (form) 368 | (cl-pattern:match form 369 | (('let _ . statements) statements) 370 | (('let . _) (error "The statement ~S is malformed." form)) 371 | (_ (error "The value ~S is an invalid statement." form)))) 372 | 373 | 374 | ;;; 375 | ;;; Let statement - binding 376 | ;;; 377 | 378 | (defun let-binding-p (object) 379 | (cl-pattern:match object 380 | ((var _) (oclcl-symbol-p var)) 381 | (_ nil))) 382 | 383 | (defun let-binding-var (binding) 384 | (unless (let-binding-p binding) 385 | (error "The value ~S is an invalid binding." binding)) 386 | (car binding)) 387 | 388 | (defun let-binding-expr (binding) 389 | (unless (let-binding-p binding) 390 | (error "The value ~S is an invalid binding." binding)) 391 | (cadr binding)) 392 | 393 | 394 | ;;; 395 | ;;; Symbol-macrolet statement 396 | ;;; 397 | 398 | (defun symbol-macrolet-p (form) 399 | (cl-pattern:match form 400 | (('symbol-macrolet . _) t) 401 | (_ nil))) 402 | 403 | (defun symbol-macrolet-bindings (form) 404 | (cl-pattern:match form 405 | (('symbol-macrolet bindings . _) 406 | (if (every #'symbol-macrolet-binding-p bindings) 407 | bindings 408 | (error "The statement ~S is malformed." form))) 409 | (('symbol-macrolet . _) (error "The statement ~S is malformed." form)) 410 | (_ (error "The value ~S is an invalid statement." form)))) 411 | 412 | (defun symbol-macrolet-statements (form) 413 | (cl-pattern:match form 414 | (('symbol-macrolet _ . statements) statements) 415 | (('symbol-macrolet . _) (error "The statement ~S is malformed." form)) 416 | (_ (error "The value ~S is an invalid statement." form)))) 417 | 418 | 419 | ;;; 420 | ;;; Symbol-macrolet statement - binding 421 | ;;; 422 | 423 | (defun symbol-macrolet-binding-p (object) 424 | (let-binding-p object)) 425 | 426 | (defun symbol-macrolet-binding-symbol (binding) 427 | (let-binding-var binding)) 428 | 429 | (defun symbol-macrolet-binding-expansion (binding) 430 | (let-binding-expr binding)) 431 | 432 | 433 | ;;; 434 | ;;; Do statement 435 | ;;; 436 | 437 | (defun do-p (form) 438 | (cl-pattern:match form 439 | (('do . _) t) 440 | (_ nil))) 441 | 442 | (defun do-bindings (form) 443 | (cl-pattern:match form 444 | (('do bindings _ . _) 445 | (if (every #'do-binding-p bindings) 446 | bindings 447 | (error "The statement ~S is malformed." form))) 448 | (('do . _) (error "The statement ~S is malformed." form)) 449 | (_ (error "The value ~S is an invalid statement." form)))) 450 | 451 | (defun do-end-test (form) 452 | (cl-pattern:match form 453 | (('do _ (end-test) . _) end-test) 454 | (('do . _) (error "The statement ~S is malformed." form)) 455 | (_ (error "The value ~S is an invalid statement." form)))) 456 | 457 | (defun do-statements (form) 458 | (cl-pattern:match form 459 | (('do _ _ . statements) statements) 460 | (('do . _) (error "The statement ~S is malformed." form)) 461 | (_ (error "The value ~S is an invalid statement." form)))) 462 | 463 | 464 | ;;; 465 | ;;; Do statement - binding 466 | ;;; 467 | 468 | (defun do-binding-p (object) 469 | (cl-pattern:match object 470 | ((var _) (oclcl-symbol-p var)) 471 | ((var _ _) (oclcl-symbol-p var)) 472 | (_ nil))) 473 | 474 | (defun do-binding-var (binding) 475 | (unless (do-binding-p binding) 476 | (error "The value ~S is an invalid binding." binding)) 477 | (car binding)) 478 | 479 | (defun do-binding-init (binding) 480 | (unless (do-binding-p binding) 481 | (error "The value ~S is an invalid binding." binding)) 482 | (cadr binding)) 483 | 484 | (defun do-binding-step (binding) 485 | (unless (do-binding-p binding) 486 | (error "The value ~S is an invalid binding." binding)) 487 | (caddr binding)) 488 | 489 | 490 | ;;; 491 | ;;; With-local-memory statement 492 | ;;; 493 | 494 | (defun with-local-memory-p (object) 495 | (cl-pattern:match object 496 | (('with-local-memory . _) t) 497 | (_ nil))) 498 | 499 | (defun with-local-memory-specs (form) 500 | (cl-pattern:match form 501 | (('with-local-memory specs . _) 502 | (if (every #'with-local-memory-spec-p specs) 503 | specs 504 | (error "The statement ~S is malformed." form))) 505 | (('with-local-memory . _) 506 | (error "The statement ~S is malformed." form)) 507 | (_ (error "The value ~S is an invalid statement." form)))) 508 | 509 | (defun with-local-memory-statements (form) 510 | (cl-pattern:match form 511 | (('with-local-memory _ . statements) statements) 512 | (('with-local-memory . _) 513 | (error "The statement ~S is malformed." form)) 514 | (_ (error "The value ~S is an invalid statement." form)))) 515 | 516 | 517 | ;;; 518 | ;;; With-local-memory statement - spec 519 | ;;; 520 | 521 | (defun with-local-memory-spec-p (object) 522 | (cl-pattern:match object 523 | ((var type . _) (and (oclcl-symbol-p var) 524 | (oclcl-type-p type))) 525 | (_ nil))) 526 | 527 | (defun with-local-memory-spec-var (spec) 528 | (unless (with-local-memory-spec-p spec) 529 | (error "The value ~S is an invalid shared memory spec." spec)) 530 | (car spec)) 531 | 532 | (defun with-local-memory-spec-type (spec) 533 | (unless (with-local-memory-spec-p spec) 534 | (error "The value ~S is an invalid shared memory spec." spec)) 535 | (cadr spec)) 536 | 537 | (defun with-local-memory-spec-dimensions (spec) 538 | (unless (with-local-memory-spec-p spec) 539 | (error "The value ~S is an invalid shared memory spec." spec)) 540 | (cddr spec)) 541 | 542 | 543 | ;;; 544 | ;;; Set statement 545 | ;;; 546 | 547 | (defun set-p (object) 548 | (cl-pattern:match object 549 | (('set _ _) t) 550 | (_ nil))) 551 | 552 | (defun set-reference (form) 553 | (cl-pattern:match form 554 | (('set reference _) (if (reference-p reference) 555 | reference 556 | (error "The statement ~S is malformed." form))) 557 | (('set . _) (error "The statement ~S is malformed." form)) 558 | (_ (error "The value ~S is an invalid statement." form)))) 559 | 560 | (defun set-expression (form) 561 | (cl-pattern:match form 562 | (('set _ expr) expr) 563 | (('set . _) (error "The statement ~S is malformed." form)) 564 | (_ (error "The value ~S is an invalid statement." form)))) 565 | 566 | ;;; 567 | ;;; Progn statement 568 | ;;; 569 | 570 | (defun progn-p (object) 571 | (cl-pattern:match object 572 | (('progn . _) t) 573 | (_ nil))) 574 | 575 | (defun progn-statements (form) 576 | (cl-pattern:match form 577 | (('progn . statements) statements) 578 | (_ (error "The value ~S is an invalid statement." form)))) 579 | 580 | 581 | ;;; 582 | ;;; Return statement 583 | ;;; 584 | 585 | (defun return-p (object) 586 | (cl-pattern:match object 587 | (('return) t) 588 | (('return _) t) 589 | (_ nil))) 590 | 591 | (defun return-expr (form) 592 | (cl-pattern:match form 593 | (('return) nil) 594 | (('return expr) expr) 595 | (('return . _) (error "The statement ~S is malformed." form)) 596 | (_ (error "The value ~S is an invalid statement." form)))) 597 | 598 | 599 | ;;; 600 | ;;; Argument 601 | ;;; 602 | 603 | (deftype argument () 604 | `(satisfies argument-p)) 605 | 606 | (defun argument-p (object) 607 | (cl-pattern:match object 608 | ((var type) (and (oclcl-symbol-p var) 609 | (oclcl-type-p type))) 610 | (_ nil))) 611 | 612 | (defun argument-var (argument) 613 | (unless (argument-p argument) 614 | (error "The value ~A is an invalid argument." argument)) 615 | (car argument)) 616 | 617 | (defun argument-type (argument) 618 | (unless (argument-p argument) 619 | (error "The value ~A is an invalid argument." argument)) 620 | (cadr argument)) 621 | 622 | ;;; 623 | ;;; Compiler directive 624 | ;;; 625 | 626 | (defun declare-p (form) 627 | (cl-pattern:match form 628 | (('declare . _) t) 629 | (_ nil))) 630 | 631 | ;;; 632 | ;;; Compiler sizeof 633 | ;;; 634 | 635 | (defun sizeof-p (form) 636 | (cl-pattern:match form 637 | (('sizeof . _) t) 638 | (_ nil))) 639 | 640 | (defun sizeof-operand (form) 641 | (unless (sizeof-p form) 642 | (error "The form ~S is invalid." form)) 643 | (cdr form)) 644 | --------------------------------------------------------------------------------