├── .gitattributes ├── .github └── workflows │ └── docs.yml ├── AST-to-BIR ├── README.md ├── cleavir-ast-to-bir.asd ├── compile-general-purpose-asts.lisp ├── compile-multiple-value-related-asts.lisp ├── compile-primops.lisp ├── infrastructure.lisp ├── packages.lisp └── staple.ext.lisp ├── AST-transformations ├── cleavir-ast-transformations.asd ├── clone.lisp ├── hoist-load-time-value.lisp ├── packages.lisp └── replace.lisp ├── Abstract-interpreter ├── association.lisp ├── attribute.lisp ├── cleavir-abstract-interpreter.asd ├── control.lisp ├── data.lisp ├── domain.lisp ├── interpret-gfs.lisp ├── interpret.lisp ├── known-call.lisp ├── packages.lisp ├── product.lisp ├── reachability.lisp ├── reachable-data.lisp ├── sequential.lisp ├── slots.lisp ├── strategy.lisp ├── type.lisp ├── typed-reachability.lisp ├── use.lisp ├── values-data.lisp └── values.lisp ├── Abstract-syntax-tree ├── Examples │ └── car.lisp ├── README.md ├── Visualizer │ ├── cleavir-ast-visualizer.asd │ ├── gui.lisp │ ├── layout.lisp │ ├── packages.lisp │ └── profiles.lisp ├── cleavir-ast.asd ├── general-purpose-asts.lisp ├── graphviz-drawing.lisp ├── map-ast.lisp ├── packages.lisp └── staple.ext.lisp ├── Attributes ├── README.md ├── attributes.lisp ├── cleavir-attributes.asd ├── flags.lisp ├── packages.lisp └── staple.ext.lisp ├── BIR-builder ├── builder.lisp ├── cleavir-bir-builder.asd └── packages.lisp ├── BIR-transformations ├── README.md ├── cleavir-bir-transformations.asd ├── copy-function.lisp ├── delete-temporary-variables.lisp ├── eliminate-come-froms.lisp ├── generate-type-checks.lisp ├── inline.lisp ├── interpolate-function.lisp ├── meta-evaluate.lisp ├── packages.lisp ├── process-captured-variables.lisp ├── simple-unwind.lisp └── staple.ext.lisp ├── BIR ├── API.md ├── README.md ├── Visualizer │ ├── README.md │ ├── application.lisp │ ├── cleavir-bir-visualizer.asd │ ├── compile.lisp │ ├── inspect.lisp │ ├── package.lisp │ ├── screenshot.png │ └── staple.ext.lisp ├── cleavir-bir.asd ├── condition-reporters-english.lisp ├── conditions.lisp ├── disassemble.lisp ├── graph-modifications.lisp ├── instructions.lisp ├── map.lisp ├── packages.lisp ├── staple.ext.lisp ├── structure.lisp └── verify.lisp ├── CST-to-AST ├── README.md ├── Test │ ├── assign-sources.lisp │ ├── ast-equal-p.lisp │ ├── ast-from-string.lisp │ ├── cleavir-cst-to-ast-test.asd │ ├── environment.lisp │ ├── make-load-form.lisp │ ├── packages.lisp │ └── test.lisp ├── cleavir-cst-to-ast.asd ├── condition-reporters-english.lisp ├── conditions.lisp ├── convert-code.lisp ├── convert-constant.lisp ├── convert-cst.lisp ├── convert-function-reference.lisp ├── convert-lambda-call.lisp ├── convert-let-and-letstar.lisp ├── convert-primop.lisp ├── convert-sequence.lisp ├── convert-setq.lisp ├── convert-special-binding.lisp ├── convert-special.lisp ├── convert-variable.lisp ├── convert.lisp ├── cst-to-ast.lisp ├── environment-augmentation.lisp ├── environment-query.lisp ├── generic-functions.lisp ├── itemize-declaration-specifiers.lisp ├── itemize-lambda-list.lisp ├── lambda-list-from-parameter-groups.lisp ├── packages.lisp ├── process-init-parameter.lisp ├── process-progn.lisp ├── set-or-bind-variable.lisp ├── staple.ext.lisp ├── utilities.lisp └── variables.lisp ├── Compilation-policy ├── README.md ├── cleavir-compilation-policy.asd ├── compute.lisp ├── condition-reporters-english.lisp ├── conditions.lisp ├── define-policy.lisp ├── optimize.lisp ├── packages.lisp ├── policy.lisp └── staple.ext.lisp ├── Conditions ├── README.md ├── cleavir-conditions.asd ├── note.lisp ├── origin.lisp ├── packages.lisp ├── program-condition.lisp └── staple.ext.lisp ├── Ctype ├── README.md ├── cleavir-ctype.asd ├── default.lisp ├── generic-functions.lisp ├── other-functions.lisp ├── packages.lisp └── staple.ext.lisp ├── Def-use-chains ├── cleavir-def-use-chains-test.asd ├── cleavir-def-use-chains.asd ├── def-use-chains.lisp ├── packages.lisp ├── test-def-use-chains.lisp └── test-packages.lisp ├── Documentation-generation ├── README.md ├── cleavir-documentation-generation.asd ├── main.ctml ├── staple.ext.lisp ├── top.css ├── top.ctml └── top.lass ├── Dominance ├── cleavir-dominance-test.asd ├── cleavir-dominance.asd ├── dominance.lisp ├── packages.lisp ├── test-dominance.lisp └── test-packages.lisp ├── Environment ├── Examples │ ├── hostile.lisp │ └── sbcl.lisp ├── README.md ├── augmentation-functions.lisp ├── cleavir-environment.asd ├── compile-time.lisp ├── declarations.lisp ├── default-augmentation-classes.lisp ├── default-info-methods.lisp ├── eval.lisp ├── optimize-qualities.lisp ├── packages.lisp ├── query.lisp ├── staple.ext.lisp └── type-information.lisp ├── Example ├── README.md ├── cleavir-example.asd ├── compile.lisp ├── derive-type.lisp ├── environment-interface.lisp ├── environment.lisp ├── fold.lisp ├── load-environment.lisp ├── macros.lisp ├── packages.lisp ├── staple.ext.lisp ├── system.lisp └── type.lisp ├── Flow ├── cleavir-flow.asd ├── flow.lisp ├── generic-functions.lisp ├── packages.lisp └── traversal.lisp ├── Graph ├── Test-utilities │ ├── cleavir-graph-test-utilities.asd │ ├── packages.lisp │ └── test-utilities.lisp ├── cleavir-graph.asd ├── defaults.lisp ├── graph.lisp └── package.lisp ├── Input-output ├── README.md ├── cleavir-io.asd ├── io.lisp ├── packages.lisp └── staple.ext.lisp ├── LICENSE ├── Liveness ├── cleavir-liveness.asd ├── liveness.lisp └── packages.lisp ├── Loops ├── cleavir-loops.asd ├── loops.lisp ├── natural-loops.lisp └── packages.lisp ├── Meter ├── cleavir-meter.asd ├── meter.lisp ├── packages.lisp └── staple.ext.lisp ├── Primop ├── cleavir-primop.asd ├── definitions.lisp ├── info.lisp ├── packages.lisp └── staple.ext.lisp ├── README.md ├── RELEASE_NOTES.md ├── Reaching-definitions ├── cleavir-reaching-definitions-test.asd ├── cleavir-reaching-definitions.asd ├── packages.lisp ├── reaching-definitions.lisp ├── test-packages.lisp └── test-reaching-definitions.lisp ├── Register-allocation ├── cleavir-register-allocation.asd ├── compute-conflicts.lisp ├── graph-coloring.lisp └── packages.lisp ├── Set ├── README.md ├── cleavir-set.asd ├── packages.lisp ├── set.lisp └── staple.ext.lisp ├── Stealth-mixins ├── README.md ├── cleavir-stealth-mixins.asd ├── packages.lisp ├── staple.ext.lisp └── stealth-mixins.lisp └── version.sexp /.gitattributes: -------------------------------------------------------------------------------- 1 | *.html linguist-generated 2 | *.css linguist-generated -------------------------------------------------------------------------------- /.github/workflows/docs.yml: -------------------------------------------------------------------------------- 1 | # Generate the website with staple, and deploy it. 2 | name: Generate and deploy docs to Pages 3 | 4 | on: 5 | push: 6 | branches: ["main"] 7 | 8 | # Allows you to run this workflow manually from the Actions tab 9 | workflow_dispatch: 10 | 11 | # Sets permissions of the GITHUB_TOKEN to allow deployment to GitHub Pages 12 | permissions: 13 | contents: read 14 | pages: write 15 | id-token: write 16 | 17 | # Allow one concurrent deployment - on new push, stop building old docs 18 | concurrency: 19 | group: "pages" 20 | cancel-in-progress: true 21 | 22 | jobs: 23 | deploy-docs: 24 | environment: 25 | name: github-pages 26 | url: ${{ steps.deployment.outputs.page_url }} 27 | runs-on: ubuntu-latest 28 | steps: 29 | - name: Install SBCL 30 | run: | 31 | sudo apt-get update 32 | sudo apt install -y sbcl 33 | - name: Install Quicklisp 34 | run: | 35 | curl -kLO https://beta.quicklisp.org/quicklisp.lisp 36 | sbcl --non-interactive --load quicklisp.lisp --eval "(quicklisp-quickstart:install)" --eval "(ql-util:without-prompting (ql:add-to-init-file))" 37 | - name: Checkout 38 | uses: actions/checkout@v3 39 | - name: Configure ASDF to find Cleavir 40 | run: | 41 | mkdir -p $HOME/.config/common-lisp/source-registry.conf.d 42 | echo "(:TREE #P\"${{ github.workspace }}/\")" > $HOME/.config/common-lisp/source-registry.conf.d/cleavir.conf 43 | - name: Generate site with Staple 44 | run: | # We quickload external dependencies since Staple doesn't. KLUDGE. 45 | sbcl --non-interactive --eval "(ql:quickload '(:staple-markdown :ctype :ctype/tfun :mcclim :clouseau))" --eval "(staple:generate :cleavir-documentation-generation :output-directory #p\"_site/\")" 46 | - name: Upload artifact 47 | uses: actions/upload-pages-artifact@v1 48 | with: 49 | # Upload entire repository 50 | path: '_site/' 51 | - name: Deploy to GitHub Pages 52 | id: deployment 53 | uses: actions/deploy-pages@v1 54 | -------------------------------------------------------------------------------- /AST-to-BIR/README.md: -------------------------------------------------------------------------------- 1 | The AST-to-BIR system converts ASTs to the block-based intermediate representation (BIR). 2 | 3 | # Use 4 | 5 | `(compile-toplevel some-ast)` is how this system should usually be used. Note that the function only accepts a function AST, as all IR must be within some function. 6 | 7 | The `compile-into-module` function can be used to add a new function into an existing module after that module's initial production. This can be useful for late transformations. 8 | 9 | # Customization 10 | 11 | Custom ASTs will need specializations of the `compile-ast` generic function. This function takes an AST, an "inserter", and the system as an argument. The inserter is an object that handles creation of IR. The `begin` function sets the iblock the inserter will insert into, while the `insert`, and `terminate` functions actually add instructions. 12 | 13 | `compile-ast` should return either `nil`, indicating the AST outputs no values; a list of one BIR datum, indicating that is returned; or `:no-return`, indicating that control aborts somehow. 14 | 15 | To smooth over handling sub-ASTs correctly, you can use `with-compiled-ast`, `with-compiled-asts`, and `with-compiled-arguments`. These macros mostly ensure that if a sub-AST of an AST always aborts, the AST itself does. 16 | -------------------------------------------------------------------------------- /AST-to-BIR/cleavir-ast-to-bir.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-ast-to-bir 4 | :description "Compiler of abstract syntax trees into BIR." 5 | :author ("Bike " 6 | "Charles Zhang") 7 | :maintainer "Bike " 8 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-ast-to-bir/" 9 | :version "1.1.0" 10 | :license "BSD" 11 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 12 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 13 | :depends-on (:cleavir-ast :cleavir-bir :cleavir-bir-builder 14 | :cleavir-primop :cleavir-ctype) 15 | :components 16 | ((:file "packages") 17 | (:file "infrastructure" :depends-on ("packages")) 18 | (:file "compile-general-purpose-asts" 19 | :depends-on ("infrastructure" "packages")) 20 | (:file "compile-multiple-value-related-asts" 21 | :depends-on ("infrastructure" "packages")) 22 | (:file "compile-primops" :depends-on ("infrastructure" "packages")))) 23 | -------------------------------------------------------------------------------- /AST-to-BIR/compile-primops.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-ast-to-bir) 2 | 3 | (defmethod compile-ast ((ast ast:primop-ast) inserter system) 4 | (with-compiled-arguments (args (ast:argument-asts ast) inserter system) 5 | (let* ((info (ast:info ast)) 6 | (out (cleavir-primop-info:out-kind info))) 7 | (let ((outputs (ecase out 8 | ((:value) (list (make-instance 'bir:output))) 9 | ((:effect) nil)))) 10 | (build:insert inserter 'bir:primop 11 | :info info :inputs args :outputs outputs) 12 | (copy-list outputs))))) 13 | 14 | (defmethod compile-test-ast ((ast ast:primop-ast) inserter system) 15 | (with-compiled-arguments (args (ast:argument-asts ast) inserter system) 16 | (let* ((info (ast:info ast))) 17 | (let* ((ibs (loop repeat 2 collect (build:make-iblock inserter))) 18 | (p-out (make-instance 'bir:output)) 19 | (p (make-instance 'bir:primop 20 | :info info :inputs args :outputs (list p-out)))) 21 | (build:insert inserter p) 22 | (build:terminate inserter 'bir:ifi 23 | :inputs (list p-out) :next ibs) 24 | (copy-list ibs))))) 25 | 26 | (defmacro defprimop (primop ast &rest readers) 27 | (let* ((info (cleavir-primop-info:info primop)) 28 | (out (cleavir-primop-info:out-kind info)) 29 | (ca `(,@(loop for reader in readers collect `(,reader ast))))) 30 | (ecase out 31 | ((2) 32 | `(defmethod compile-test-ast ((ast ,ast) inserter system) 33 | (with-compiled-asts (args ,ca inserter system) 34 | (let ((ibs 35 | (list ,@(loop repeat out 36 | collect `(build:make-iblock inserter)))) 37 | (p-out (make-instance 'bir:output))) 38 | (build:insert inserter 'bir:primop 39 | :info ',info :inputs args :outputs (list p-out)) 40 | (build:terminate inserter 'bir:ifi 41 | :inputs (list p-out) :next ibs) 42 | (copy-list ibs))))) 43 | ((:value :effect) 44 | `(defmethod compile-ast ((ast ,ast) inserter system) 45 | (with-compiled-asts (args ,ca inserter system) 46 | (let ((outs ,(ecase out 47 | ((:value) 48 | '(list (make-instance 'bir:output))) 49 | ((:effect) nil)))) 50 | (build:insert inserter 'bir:primop 51 | :info ',info :inputs args :outputs outs) 52 | (copy-list outs)))))))) 53 | -------------------------------------------------------------------------------- /AST-to-BIR/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-ast-to-bir 4 | (:use #:cl) 5 | (:shadow #:function) 6 | (:local-nicknames (#:set #:cleavir-set) 7 | (#:ast #:cleavir-ast) 8 | (#:bir #:cleavir-bir) 9 | (#:build #:cleavir-bir-builder) 10 | (#:ctype #:cleavir-ctype)) 11 | (:export #:compile-toplevel #:compile-into-module #:compile-function 12 | #:compile-ast #:compile-test-ast #:compile-arguments 13 | #:compile-sequence-for-effect) 14 | (:export #:inline-origin) 15 | (:export #:with-compiled-ast #:with-compiled-asts #:with-compiled-arguments) 16 | (:export #:defprimop)) 17 | -------------------------------------------------------------------------------- /AST-to-BIR/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-ast-to-bir)))) 4 | (list (find-package "CLEAVIR-AST-TO-BIR"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-ast-to-bir)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /AST-transformations/cleavir-ast-transformations.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-ast-transformations 4 | :depends-on (:cleavir-ast) 5 | :serial t 6 | :components 7 | ((:file "packages") 8 | (:file "clone") 9 | (:file "replace") 10 | (:file "hoist-load-time-value"))) 11 | -------------------------------------------------------------------------------- /AST-transformations/hoist-load-time-value.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-ast-transformations) 2 | 3 | (defun find-load-time-value-asts (ast) 4 | (let ((result '())) 5 | (cleavir-ast:map-ast-depth-first-preorder 6 | (lambda (node) 7 | (when (typep node 'cleavir-ast:load-time-value-ast) 8 | (push node result))) 9 | ast) 10 | result)) 11 | 12 | (defun hoist-load-time-value (ast) 13 | (let* ((load-time-value-asts (find-load-time-value-asts ast)) 14 | (forms (mapcar #'cleavir-ast:form load-time-value-asts))) 15 | (loop for ast in load-time-value-asts 16 | do (change-class ast 'cleavir-ast:lexical-ast :name (gensym))) 17 | (cleavir-ast:make-top-level-function-ast 18 | ast load-time-value-asts forms 19 | :policy (cleavir-ast:policy ast)))) 20 | -------------------------------------------------------------------------------- /AST-transformations/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-ast-transformations 4 | (:use #:common-lisp) 5 | (:export 6 | #:hoist-load-time-value 7 | #:clone-ast 8 | #:codegen-clone-ast)) 9 | -------------------------------------------------------------------------------- /AST-transformations/replace.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-ast-transformations) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Replacing a node in an AST. 6 | ;;; 7 | ;;; Given an AST and a FUNCTION, the FUNCTION is applied to each node 8 | ;;; of the AST. If on some node N, the function returns NIL then N is 9 | ;;; cloned. Otherwise, the return value of FUNCTION is a node that 10 | ;;; should replace N in the copy. 11 | 12 | (defun reinitialize (instance keyword replacement) 13 | (reinitialize-instance instance keyword replacement)) 14 | 15 | (defun replace-ast (ast function) 16 | (let ((dictionary (make-hash-table :test #'eq))) 17 | (cleavir-ast:map-ast-depth-first-preorder 18 | (lambda (node) 19 | (let ((replacement (funcall function node))) 20 | (unless (null replacement) 21 | (setf (gethash node dictionary) replacement)))) 22 | ast) 23 | (cleavir-ast:map-ast-depth-first-preorder 24 | (lambda (node) 25 | (loop for (keyword reader) in (cleavir-io:save-info node) 26 | for value = (funcall reader node) 27 | for replacement = (gethash value dictionary) 28 | unless (null replacement) 29 | do (reinitialize node keyword replacement))) 30 | ast))) 31 | -------------------------------------------------------------------------------- /Abstract-interpreter/association.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-abstract-interpreter) 2 | 3 | (defgeneric info (domain object)) 4 | (defgeneric (setf info) (new-info domain object) 5 | (:argument-precedence-order domain object new-info)) 6 | -------------------------------------------------------------------------------- /Abstract-interpreter/cleavir-abstract-interpreter.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-abstract-interpreter 4 | :description "Abstract interpreter for BIR." 5 | :author "Bike " 6 | :version "0.0.1" 7 | :license "BSD" 8 | :depends-on (:cleavir-bir :cleavir-set :cleavir-stealth-mixins 9 | :cleavir-attributes :cleavir-ctype) 10 | :components 11 | ((:file "packages") 12 | (:file "domain" :depends-on ("packages")) 13 | (:file "strategy" :depends-on ("packages")) 14 | (:file "values" :depends-on ("domain" "packages")) 15 | (:file "interpret-gfs" :depends-on ("packages")) 16 | (:file "product" :depends-on ("interpret-gfs" "domain" "packages")) 17 | (:file "interpret" :depends-on ("product" "interpret-gfs" "packages")) 18 | (:file "sequential" :depends-on ("product" "interpret" "packages")) 19 | (:file "control" :depends-on ("interpret-gfs" "domain" "packages")) 20 | (:file "reachability" :depends-on ("control" "domain" "packages")) 21 | (:file "data" :depends-on ("interpret-gfs" "domain" "packages")) 22 | (:file "values-data" :depends-on ("data" "values" "packages")) 23 | (:file "attribute" :depends-on ("values-data" "packages")) 24 | (:file "known-call" :depends-on ("attribute" "product" "values-data" "packages")) 25 | (:file "type" :depends-on ("values-data" "interpret-gfs" "packages")) 26 | (:file "use" :depends-on ("values-data" "interpret-gfs" "packages")) 27 | (:file "reachable-data" :depends-on ("product" "reachability" "data" "packages")) 28 | (:file "typed-reachability" :depends-on ("product" "type" "reachability" "packages")) 29 | (:file "slots" :depends-on ("sequential" "attribute" "type" "interpret-gfs" 30 | "packages")))) 31 | -------------------------------------------------------------------------------- /Abstract-interpreter/interpret-gfs.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-abstract-interpreter) 2 | 3 | #| 4 | Conceptually, each domain and instruction (program point) pair is associated with 5 | an info pertaining to that domain. This is true regardless of the direction of 6 | the domain, and is true even of data domains (data.lisp) where we don't actually 7 | store the info with the instruction. 8 | Sometimes this "info" is actually a list of info objects. For example for data 9 | domains, there will be one info for each datum. For forward control domains 10 | there will be one info for each of an instruction's successors. It may make more 11 | sense to think of individual infos as being associated with edges - either 12 | control flow edges for control domains, or def/use edges for data domains. 13 | 14 | When implementing a domain, FLOW-INSTRUCTION is the main function to write. 15 | FLOW-INSTRUCTION receives as arguments the domain, the instruction, and the list 16 | of infos associated with the instruction. Methods should compute the infos for 17 | the post-instruction point and return them as values. 18 | 19 | INTERPRET-INSTRUCTION does the actual side effectual stuff within the interpreter, 20 | and ideally should not need to be customized per-domain. 21 | 22 | The point of all this abstraction is basically to make each individual domain 23 | implementation as crystal clear and to the point as possible. They shouldn't have 24 | to reimplement basic aspects of function call semantics, etc. 25 | |# 26 | 27 | ;;; Mark that an instruction needs reinterpretation. 28 | ;;; This may or may not result in immediate interpretation, depending on the strategy. 29 | ;;; Called for effect. Internal. 30 | ;;; TODO: Could have a version that works per-domain, maybe save some time? 31 | (defgeneric mark (strategy instruction)) 32 | 33 | ;;; Perform abstract interpretation on a module. 34 | (defgeneric interpret-module (strategy product module)) 35 | 36 | ;;; Given an instruction, set its info to the initial state for a strategy and domain. 37 | ;;; Called for effect. Internal. 38 | (defgeneric initialize-instruction (strategy domain instruction)) 39 | 40 | ;;; Given an entry point (i.e. a function that could be called from anywhere), 41 | ;;; initialize some infos for that appropriately. Used during interpreting a module. 42 | ;;; Called for effect. Internal. 43 | (defgeneric initialize-entry-point (strategy domain function)) 44 | 45 | ;;; In the below, a domain can be used as a channel, indicating a scalar channel 46 | ;;; from the domain to itself. 47 | 48 | ;;; Given infos for the input (for forward domains) or output (for backward), 49 | ;;; compute infos for the other. Main customization point. 50 | (defgeneric flow-instruction (channel instruction &rest infos)) 51 | 52 | ;;; Return the input infos to pass to FLOW-INSTRUCTION. Internal. 53 | (defgeneric instruction-input-info (strategy channel instruction)) 54 | 55 | ;;; Given the output infos computed by FLOW-INSTRUCTION, store that information 56 | ;;; and possibly mark other instructions for reinterpretation. 57 | ;;; Internal. Called for effect. 58 | (defgeneric instruction-output-info (strategy domain instruction &rest infos)) 59 | 60 | ;;; Access the information in a domain for a given program object. 61 | (defgeneric info (strategy domain object)) 62 | (defgeneric (setf info) (new-info strategy domain object) 63 | (:argument-precedence-order strategy domain object new-info)) 64 | -------------------------------------------------------------------------------- /Abstract-interpreter/interpret.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-abstract-interpreter) 2 | 3 | ;;;; Actual definition of INTERPRET-INSTRUCTION. 4 | 5 | (defun input-channels (product output-domain) 6 | (remove-if-not (lambda (channel) (output-domain-p channel output-domain)) 7 | (channels product))) 8 | 9 | (defun outputs-for-domain (strategy product domain instruction) 10 | (declare (optimize debug)) 11 | (let ((input-channels (input-channels product domain))) 12 | (if (null input-channels) ; quick case 13 | (multiple-value-call #'flow-instruction domain instruction 14 | (instruction-input-info strategy domain instruction)) 15 | ;; MEET all the output infos with that from the domain itself. 16 | (flet ((outputs-list (channel) 17 | (multiple-value-list 18 | (multiple-value-call #'flow-instruction channel instruction 19 | (instruction-input-info strategy channel instruction)))) 20 | (dmeet (info1 info2) (meet domain info1 info2))) 21 | (loop with total-output-infos = (outputs-list domain) 22 | for channel in input-channels 23 | for output-infos = (outputs-list channel) 24 | do (map-into total-output-infos #'dmeet 25 | total-output-infos output-infos) 26 | finally (return (values-list total-output-infos))))))) 27 | 28 | (defun interpret-one-domain (strategy product domain instruction) 29 | (multiple-value-call #'instruction-output-info 30 | strategy domain instruction 31 | (outputs-for-domain strategy product domain instruction))) 32 | 33 | ;;; Perform abstract interpretation of an instruction. This should result in 34 | ;;; info changes and marking if there is better information. 35 | ;;; Called for effect. Internal. 36 | ;;; Hypothetically we could have a version that only updates domains with new 37 | ;;; info. FIXME? 38 | (defun interpret-instruction (strategy product instruction) 39 | (loop for domain in (domains product) 40 | do (interpret-one-domain strategy product domain instruction))) 41 | -------------------------------------------------------------------------------- /Abstract-interpreter/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-abstract-interpreter 4 | (:use #:cl) 5 | (:local-nicknames (#:bir #:cleavir-bir) 6 | (#:set #:cleavir-set) 7 | (#:ctype #:cleavir-ctype) 8 | (#:attributes #:cleavir-attributes)) 9 | (:shadow #:type) 10 | (:export #:domain 11 | #:infimum #:supremum #:subinfop #:join/2 #:meet/2 12 | #:meet #:join #:widen) 13 | (:export #:data #:forward-data #:backward-data 14 | #:values-domain #:forward-values-data #:backward-values-data 15 | #:control #:forward-control) 16 | (:export #:sv-infimum #:sv-supremum #:sv-subinfop 17 | #:sv-join/2 #:sv-meet/2 #:sv-widen 18 | #:values-info #:values-required #:values-optional #:values-rest 19 | #:info-values-nth #:primary #:single-value) 20 | (:export #:product #:channel #:scalar-channel #:coop-channel) 21 | (:export #:strategy #:optimism #:pessimism 22 | #:mark #:interpret-module #:flow-instruction 23 | #:info) 24 | (:export #:attribute) 25 | (:export #:known-call-channel #:flow-known-call) 26 | (:export #:type #:derived-type #:asserted-type) 27 | (:export #:reachability) 28 | (:export #:reachability->data #:type->reachability) 29 | (:export #:sequential) 30 | (:export #:slots #:sequential-slots)) 31 | -------------------------------------------------------------------------------- /Abstract-interpreter/reachability.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-abstract-interpreter) 2 | 3 | (defclass reachability (noetherian-mixin forward-control) ()) 4 | 5 | ;;; Reachability info is T (maybe reachable) or NIL (not reachable). 6 | 7 | (defmethod infimum ((domain reachability)) nil) 8 | (defmethod supremum ((domain reachability)) t) 9 | (defmethod subinfop ((domain reachability) info1 info2) (or info2 (not info1))) 10 | (defmethod join/2 ((domain reachability) info1 info2) (or info1 info2)) 11 | (defmethod meet/2 ((domain reachability) info1 info2) (and info1 info2)) 12 | 13 | ;;; Just pass reachability through. 14 | ;;; Refinements to this analysis use additional information; for example see 15 | ;;; typed-reachability.lisp. 16 | (defmethod flow-instruction ((domain reachability) (instruction bir:instruction) 17 | &rest infos) 18 | (let ((info (first infos))) 19 | (if (or (bir:successor instruction) 20 | (= (length (bir:next instruction)) 1)) 21 | info 22 | (values-list (make-list (length (bir:next instruction)) :initial-element info))))) 23 | -------------------------------------------------------------------------------- /Abstract-interpreter/reachable-data.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-abstract-interpreter) 2 | 3 | (defclass reachability->data (scalar-channel) 4 | ((%input :type reachability) (%output :type data))) 5 | 6 | (defmethod flow-instruction ((channel reachability->data) (instruction bir:instruction) 7 | &rest infos) 8 | ;; If an instruction is unreachable, all its outputs are the infimum. 9 | (values-list (make-list (length (bir:outputs instruction)) 10 | :initial-element (if (null (first infos)) 11 | (infimum (output channel)) 12 | (supremum (output channel)))))) 13 | (defmethod flow-instruction ((channel reachability->data) (inst bir:one-output) 14 | &rest infos) 15 | (if (null (first infos)) 16 | (infimum (output channel)) 17 | (supremum (output channel)))) 18 | (defmethod flow-instruction ((channel reachability->data) (inst bir:no-output) 19 | &rest infos) 20 | (declare (ignore infos)) 21 | (values)) 22 | -------------------------------------------------------------------------------- /Abstract-interpreter/sequential.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-abstract-interpreter) 2 | 3 | ;;;; The SEQUENTIAL strategy proceeds sequentially: it interprets every 4 | ;;;; instruction once, moving in forward flow order, then continues in backward 5 | ;;;; then forward flow order again and again until no new information is made 6 | ;;;; available. 7 | 8 | ;;; TODO?: Move work flag into instructions, or otherwise ensure that flowing is 9 | ;;; non consing in itself. 10 | (defclass sequential (strategy) 11 | ((%mark-table :initform (make-hash-table) :reader mark-table))) 12 | 13 | (defmethod mark ((strategy sequential) instruction) 14 | (setf (gethash instruction (mark-table strategy)) t)) 15 | (defun unmark (strategy instruction) 16 | (remhash instruction (mark-table strategy))) 17 | 18 | ;;; 19 | 20 | (defmethod interpret-module ((strategy sequential) (product product) (module bir:module)) 21 | ;; Initialize all infos and entry points. 22 | (let ((domains (domains product))) 23 | (bir:do-functions (function module) 24 | (bir:map-local-instructions 25 | (lambda (inst) 26 | (dolist (domain domains) 27 | (initialize-instruction strategy domain inst))) 28 | function)) 29 | ;; Entry points. FIXME: BIR should indicate entry points better. 30 | (bir:do-functions (function module) 31 | (when (or (bir:enclose function) (set:empty-set-p (bir:local-calls function))) 32 | (dolist (domain domains) 33 | (initialize-entry-point strategy domain function))))) 34 | (bir:do-functions (function module) 35 | ;; Unconditionally interpret every instruction (forward, arbitrarily) 36 | (interpret-function-forward strategy product function (constantly t))) 37 | ;; Now iterate through every instruction repeatedly until we hit a fixpoint. 38 | (let ((table (mark-table strategy))) 39 | (flet ((markedp (instruction) 40 | (values (gethash instruction table)))) 41 | (loop 42 | (bir:do-functions (function module) 43 | (when (zerop (hash-table-count table)) (return-from interpret-module)) 44 | (interpret-function-backward strategy product function #'markedp) 45 | (when (zerop (hash-table-count table)) (return-from interpret-module)) 46 | (interpret-function-forward strategy product function #'markedp)))))) 47 | 48 | (defun interpret-function-forward (strategy product function predicate) 49 | (bir:do-iblocks (ib function :forward) 50 | (bir:do-iblock-instructions (inst ib :forward) 51 | (maybe-interpret-instruction strategy product inst predicate)))) 52 | 53 | (defun interpret-function-backward (strategy product function predicate) 54 | (bir:do-iblocks (ib function :backward) 55 | (bir:do-iblock-instructions (inst ib :backward) 56 | (maybe-interpret-instruction strategy product inst predicate)))) 57 | 58 | (defun maybe-interpret-instruction (strategy product instruction predicate) 59 | (when (funcall predicate instruction) 60 | (unmark strategy instruction) 61 | (interpret-instruction strategy product instruction)) 62 | (values)) 63 | -------------------------------------------------------------------------------- /Abstract-interpreter/slots.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-abstract-interpreter) 2 | 3 | (defclass slots (pessimism) ()) 4 | 5 | (defclass sequential-slots (slots sequential) ()) 6 | 7 | ;;; Abstract interpreter fields are stored directly in data and/or instructions, 8 | ;;; via stealth mixins. 9 | ;;; FIXME: Maybe make this optionally loaded or something? 10 | 11 | (cleavir-stealth-mixins:define-stealth-mixin datum () bir:datum 12 | ((%asserted-type :accessor asserted-type) 13 | (%derived-type :accessor derived-type) 14 | (%attributes :accessor attributes))) 15 | 16 | (defmethod info ((strategy slots) (domain asserted-type) (datum datum)) 17 | (asserted-type datum)) 18 | (defmethod (setf info) (new (strategy slots) 19 | (domain asserted-type) (datum datum)) 20 | (setf (asserted-type datum) new)) 21 | 22 | (defmethod info ((strategy slots) (domain derived-type) (datum datum)) 23 | (derived-type datum)) 24 | (defmethod (setf info) (new (strategy slots) 25 | (domain derived-type) (datum datum)) 26 | (setf (derived-type datum) new)) 27 | 28 | (defmethod info ((strategy slots) (domain attribute) (datum datum)) 29 | (attributes datum)) 30 | (defmethod (setf info) (new (strategy slots) 31 | (domain attribute) (datum datum)) 32 | (setf (attributes datum) new)) 33 | 34 | (cleavir-stealth-mixins:define-stealth-mixin instruction () bir:instruction 35 | ((%reachablep :accessor reachablep))) 36 | 37 | (defmethod info ((strategy slots) (domain reachability) (inst instruction)) 38 | (reachablep inst)) 39 | (defmethod (setf info) (new (strategy slots) 40 | (domain reachability) (inst instruction)) 41 | (setf (reachablep inst) new)) 42 | -------------------------------------------------------------------------------- /Abstract-interpreter/strategy.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-abstract-interpreter) 2 | 3 | ;;; A STRATEGY is used to describe how interpretation proceeds. The strategy 4 | ;;; determines how instructions are interpreted and in what order, as well as 5 | ;;; how information is associated with program objects. 6 | ;;; It does not define the nature of the information itself- that's the domain. 7 | (defclass strategy () ()) 8 | 9 | ;;; The OPTIMISM mixin describes optimistic strategies, i.e. strategies that 10 | ;;; start all program objects as being linked to the infimum of the domains. 11 | ;;; This can give a better approximation to the least fixed point than the 12 | ;;; pessimistic strategy, but means that until interpretation is complete the 13 | ;;; information associated with an object may be incorrect. 14 | (defclass optimism (strategy) ()) 15 | ;;; The PESSIMISM mixin describes pessimistic strategies that start all program 16 | ;;; objects as having the supremum of the domains. This can give a worse 17 | ;;; approximation than optimism, but on the other hand, at no point is the 18 | ;;; information associated with an object incorrect. 19 | (defclass pessimism (strategy) ()) 20 | 21 | ;;; Is this a thing where we need to use a widening operator instead of the usual? 22 | (defgeneric widening-point-p (strategy thing)) 23 | -------------------------------------------------------------------------------- /Abstract-interpreter/typed-reachability.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-abstract-interpreter) 2 | 3 | ;;;; Refinements to the reachability analysis based on type information. 4 | 5 | (defclass type->reachability (scalar-channel) 6 | ((%input :type type) (%output :type reachability))) 7 | 8 | (defmethod flow-instruction ((channel type->reachability) (instruction bir:ifi) 9 | &rest infos) 10 | ;; Only mark the ELSE branch as reachable if NIL is a member of the input's type, 11 | ;; and similar with THEN. 12 | (let* ((reach (output channel)) (inf (infimum reach)) (sup (supremum reach)) 13 | (type (input channel)) (sys (system type)) 14 | (itype (ctype:primary (first infos) sys)) 15 | (false (ctype:member sys nil)) 16 | (true (ctype:negate false sys))) 17 | (values (if (ctype:disjointp itype false sys) inf sup) 18 | (if (ctype:disjointp itype true sys) inf sup)))) 19 | -------------------------------------------------------------------------------- /Abstract-interpreter/use.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-abstract-interpreter) 2 | 3 | (defclass usage (backward-values-data) ()) 4 | 5 | (defclass use () ()) 6 | (defclass unused (use) ()) 7 | (defclass low-bits (use) ; used for modular arithmetic 8 | ((%nbits :initarg :nbits :reader use-nbits :type (integer 0)))) 9 | (defclass bool-use (use) ()) ; used as a boolean, e.g. input to IF 10 | (defclass all-use (use) ()) ; used arbitrarily 11 | 12 | (defmethod sv-subinfop ((domain usage) (i1 unused) (i2 use)) (values t t)) 13 | (defmethod sv-subinfop ((domain usage) (i1 use) (i2 all-use)) (values t t)) 14 | (defmethod sv-subinfop ((domain usage) (i1 low-bits) (i2 low-bits)) 15 | (values (<= (use-nbits i1) (use-nbits i2)) t)) 16 | (defmethod sv-subinfop ((domain usage) (i1 bool-use) (i2 bool-use)) (values t t)) 17 | (defmethod sv-subinfop ((domain usage) (i1 low-bits) (i2 bool-use)) (values nil t)) 18 | (defmethod sv-subinfop ((domain usage) (i1 bool-use) (i2 low-bits)) (values nil t)) 19 | 20 | (defmethod sv-join/2 ((domain usage) (i1 unused) (i2 use)) i2) 21 | (defmethod sv-join/2 ((domain usage) (i1 use) (i2 unused)) i1) 22 | (defmethod sv-join/2 ((domain usage) (i1 use) (i2 all-use)) i2) 23 | (defmethod sv-join/2 ((domain usage) (i1 all-use) (i2 use)) i1) 24 | (defmethod sv-join/2 ((domain usage) (i1 low-bits) (i2 low-bits)) 25 | (if (<= (use-nbits i1) (use-nbits i2)) i2 i1)) 26 | (defmethod sv-join/2 ((domain usage) (i1 bool-use) (i2 bool-use)) i1) 27 | (defmethod sv-join/2 ((domain usage) (i1 low-bits) (i2 bool-use)) (make-instance 'all-use)) 28 | (defmethod sv-join/2 ((domain usage) (i1 bool-use) (i2 low-bits)) (make-instance 'all-use)) 29 | 30 | (defmethod sv-meet/2 ((domain usage) (i1 unused) (i2 use)) i1) 31 | (defmethod sv-meet/2 ((domain usage) (i1 use) (i2 unused)) i2) 32 | (defmethod sv-meet/2 ((domain usage) (i1 use) (i2 all-use)) i1) 33 | (defmethod sv-meet/2 ((domain usage) (i1 all-use) (i2 use)) i2) 34 | (defmethod sv-meet/2 ((domain usage) (i1 low-bits) (i2 low-bits)) 35 | (if (<= (use-nbits i1) (use-nbits i2)) i1 i2)) 36 | (defmethod sv-meet/2 ((domain usage) (i1 bool-use) (i2 bool-use)) i1) 37 | (defmethod sv-meet/2 ((domain usage) (i1 low-bits) (i2 bool-use)) (make-instance 'unused)) 38 | (defmethod sv-meet/2 ((domain usage) (i1 bool-use) (i2 low-bits)) (make-instance 'unused)) 39 | 40 | (defmethod sv-infimum ((domain usage)) (make-instance 'unused)) 41 | (defmethod sv-supremum ((domain usage)) (make-instance 'all-use)) 42 | 43 | (defmethod flow-instruction ((domain usage) (inst bir:ifi) &rest infos) 44 | (declare (ignore infos)) 45 | (single-value domain (make-instance 'bool-use))) 46 | -------------------------------------------------------------------------------- /Abstract-interpreter/values-data.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-abstract-interpreter) 2 | 3 | ;;;; Forward and backward data flows for values data. 4 | 5 | ;;; Mark arguments as sv-sup. 6 | (defmethod initialize-entry-point ((strategy strategy) (domain forward-values-data) 7 | (function bir:function)) 8 | ;; Make the arguments supreme. 9 | (let ((sup (single-value domain (sv-supremum domain)))) 10 | (bir:map-lambda-list 11 | (lambda (state item index) 12 | (declare (ignore index)) 13 | (ecase state 14 | ((:required &rest) 15 | (setf (info strategy domain item) sup)) 16 | ((&optional) 17 | (setf (info strategy domain (first item)) sup 18 | (info strategy domain (second item)) sup)) 19 | ((&key) 20 | (setf (info strategy domain (second item)) sup 21 | (info strategy domain (third item)) sup)))) 22 | (bir:lambda-list function)))) 23 | 24 | (defmethod flow-instruction ((domain forward-values-data) (inst bir:fixed-to-multiple) 25 | &rest in-infos) 26 | (ftm-info domain (mapcar (lambda (i) (primary domain i)) in-infos))) 27 | 28 | (defmethod flow-instruction ((domain backward-values-data) (inst bir:fixed-to-multiple) 29 | &rest in-infos) 30 | (values-list (loop with info = (first in-infos) 31 | for i from 0 below (length (bir:inputs inst)) 32 | collect (single-value domain (info-values-nth domain i info))))) 33 | 34 | (defmethod flow-instruction ((domain forward-values-data) (inst bir:writevar) 35 | &rest in-infos) 36 | (single-value domain (primary domain (first in-infos)))) 37 | (defmethod flow-instruction ((domain backward-values-data) (inst bir:readvar) 38 | &rest in-infos) 39 | (single-value domain (primary domain (first in-infos)))) 40 | -------------------------------------------------------------------------------- /Abstract-syntax-tree/Examples/car.lisp: -------------------------------------------------------------------------------- 1 | ;;;; This example shows an AST that implements the CAR function. 2 | ;;;; 3 | ;;;; It corresponds to the following source code: 4 | ;;;; 5 | ;;;; (lambda (object) 6 | ;;;; (if (cleavir-primop:typeq object null) 7 | ;;;; nil 8 | ;;;; (if (cleavir-primop:typeq object cons) 9 | ;;;; (cleavir-primop:car object) 10 | ;;;; (error 'type-error 11 | ;;;; :datum object 12 | ;;;; :expected-type '(or cons null))))) 13 | ;;;; 14 | ;;;; Where CLEAVIR-PRIMOP:TYPEQ is a special operator that produces 15 | ;;;; the TYPEQ-AST, and CLEAVIR-PRIMOP:CAR is a special operator that 16 | ;;;; produces the CAR-AST. 17 | 18 | [CLEAVIR-AST:FUNCTION-AST 19 | :LAMBDA-LIST 20 | (#1=[CLEAVIR-AST:LEXICAL-AST 21 | :NAME 22 | COMMON-LISP-USER::X 23 | :CHILDREN 24 | COMMON-LISP:NIL ]) 25 | :CHILDREN 26 | ([CLEAVIR-AST:PROGN-AST 27 | :CHILDREN 28 | ([CLEAVIR-AST:IF-AST 29 | :CHILDREN 30 | ([CLEAVIR-AST:TYPEQ-AST 31 | :CHILDREN 32 | (#1# 33 | [CLEAVIR-AST:CONSTANT-AST 34 | :VALUE 35 | COMMON-LISP:NULL 36 | :CHILDREN 37 | COMMON-LISP:NIL ]) ] 38 | [CLEAVIR-AST:CONSTANT-AST 39 | :VALUE 40 | COMMON-LISP:NIL 41 | :CHILDREN 42 | COMMON-LISP:NIL ] 43 | [CLEAVIR-AST:IF-AST 44 | :CHILDREN 45 | ([CLEAVIR-AST:TYPEQ-AST 46 | :CHILDREN 47 | (#1# 48 | [CLEAVIR-AST:CONSTANT-AST 49 | :VALUE 50 | COMMON-LISP:CONS 51 | :CHILDREN 52 | COMMON-LISP:NIL ]) ] 53 | [CLEAVIR-AST:CAR-AST :CHILDREN (#1#) ] 54 | [CLEAVIR-AST:CALL-AST 55 | :CHILDREN 56 | ([CLEAVIR-AST:GLOBAL-AST 57 | :FUNCTION-TYPE 58 | (COMMON-LISP:AND) 59 | :NAME 60 | COMMON-LISP:ERROR 61 | :CHILDREN 62 | COMMON-LISP:NIL ] 63 | [CLEAVIR-AST:CONSTANT-AST 64 | :VALUE 65 | COMMON-LISP:TYPE-ERROR 66 | :CHILDREN 67 | COMMON-LISP:NIL ] 68 | [CLEAVIR-AST:CONSTANT-AST 69 | :VALUE 70 | :DATUM 71 | :CHILDREN 72 | COMMON-LISP:NIL ] 73 | #1# 74 | [CLEAVIR-AST:CONSTANT-AST 75 | :VALUE 76 | :EXPECTED-TYPE 77 | :CHILDREN 78 | COMMON-LISP:NIL ] 79 | [CLEAVIR-AST:CONSTANT-AST 80 | :VALUE 81 | (COMMON-LISP:OR COMMON-LISP:NULL COMMON-LISP:CONS) 82 | :CHILDREN 83 | COMMON-LISP:NIL ]) ]) ]) ]) ]) ] 84 | -------------------------------------------------------------------------------- /Abstract-syntax-tree/README.md: -------------------------------------------------------------------------------- 1 | We define the abstract syntax trees (ASTs) that represent Common Lisp code. The AST is a very close representation of the source code, except that the environment is no longer present, so that there are no longer any different namespaces for functions and variables. And of course, operations such as MACROLET are not present because they only alter the environment. 2 | 3 | The AST form is the preferred representation for some operations; in particular for the first stage of PROCEDURE INTEGRATION (sometimes called INLINING). It is the first stage of IR used by Cleavir. 4 | 5 | # Particular AST classes 6 | 7 | There is mostly a different type of AST for each Common Lisp 8 | special operator, but there are some exceptions. Here are the 9 | Common Lisp special operators: `BLOCK`, `CATCH`, `EVAL-WHEN`, `FLET`, 10 | `FUNCTION`, `GO`, `IF`, `LABELS`, `LET`, `LET*`, `LOAD-TIME-VALUE`, `LOCALLY`, 11 | `MACROLET`, `MULTIPLE-VALUE-CALL`, `MULTIPLE-VALUE-PROG1`, `PROGN`, `PROGV`, 12 | `QUOTE`, `RETURN-FROM`, `SETQ`, `SYMBOL-MACROLET`, `TAGBODY`, `THE`, `THROW`, 13 | `UNWIND-PROTECT`. 14 | 15 | Some of these only influence the environment and do not need a 16 | representation as ASTs. These are: `LOCALLY`, `MACROLET`, and 17 | `SYMBOL-MACROLET`. 18 | 19 | `FLET` and `LABELS` are like `LET` except that the symbols the bind are 20 | in the function namespace, but the distinciton between namespeces 21 | no longer exists in the AST. 22 | 23 | A `LAMBDA` expression, either inside `(FUNCTION (LAMBDA ...))` or when 24 | it is the `CAR` of a compound form, compiles into a `FUNCTION-AST`. 25 | The other kind of `FUNCTION` special form, a function lookup, will end 26 | up as either a `LEXICAL-AST` for local functions, or a `CONSTANT-FDEFINITION-AST` 27 | for global. 28 | 29 | We also define ASTs that do not correspond to any Common Lisp 30 | special operators, because we simplify later code generation that 31 | way. 32 | -------------------------------------------------------------------------------- /Abstract-syntax-tree/Visualizer/cleavir-ast-visualizer.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem #:cleavir-ast-visualizer 4 | :depends-on (#:cleavir-ast 5 | #:mcclim 6 | #:clouseau) 7 | :serial t 8 | :components 9 | ((:file "packages") 10 | (:file "profiles") 11 | (:file "layout") 12 | (:file "gui"))) 13 | -------------------------------------------------------------------------------- /Abstract-syntax-tree/Visualizer/layout.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-ast-visualizer) 2 | 3 | (defclass layout () 4 | ((%ast :initarg :ast :reader ast) 5 | (%indirect-p :initarg :indirect-p :reader indirect-p) 6 | (%position :initarg :position :accessor position) 7 | (%children :initarg :children :reader children) 8 | (%profile :initarg :profile :reader profile))) 9 | 10 | (defun move-layout (layout dx dy) 11 | (with-accessors ((position position)) layout 12 | (setf position (make-point (+ (x position) dx) (+ (y position) dy)))) 13 | (loop for child in (children layout) 14 | do (move-layout child dx dy))) 15 | 16 | (defun combine-layouts (layouts) 17 | (destructuring-bind (first . rest) layouts 18 | (loop with accumulated-profile = (profile first) 19 | for layout in rest 20 | for profile = (profile layout) 21 | do (multiple-value-bind (new-profile dy) 22 | (combine-vertical-profiles accumulated-profile profile) 23 | (setf accumulated-profile new-profile) 24 | (move-layout layout 0 dy)) 25 | finally (return accumulated-profile)))) 26 | 27 | (defgeneric layout-from-ast (table pane ast)) 28 | 29 | (defun layout-from-ast-with-children (table pane ast children) 30 | (let ((width (ast-width pane ast)) 31 | (height (ast-height pane ast))) 32 | (cond ((gethash ast table) 33 | (make-instance 'layout 34 | :ast ast 35 | :position (make-point 0 2) 36 | :profile (list (make-point 1 4)) 37 | :children '() 38 | :indirect-p t)) 39 | ((null children) 40 | (setf (gethash ast table) t) 41 | (make-instance 'layout 42 | :ast ast 43 | :position (make-point 0 0) 44 | :profile (list (make-point (+ width 20) (+ height 20))) 45 | :children '() 46 | :indirect-p nil)) 47 | (t (setf (gethash ast table) t) 48 | (let* ((children (loop for child in children 49 | collect (layout-from-ast table pane child))) 50 | (child-profiles (combine-layouts children)) 51 | (profile (combine-horizontal-profiles 52 | (make-point (+ width 20) (+ height 20)) 53 | child-profiles))) 54 | (loop for child in children 55 | do (move-layout child (+ width 20) 0)) 56 | (make-instance 'layout 57 | :ast ast 58 | :position (make-point 0 0) 59 | :profile profile 60 | :children children 61 | :indirect-p nil)))))) 62 | 63 | (defmethod layout-from-ast (table pane ast) 64 | (layout-from-ast-with-children table pane ast (cleavir-ast:children ast))) 65 | 66 | (defmethod layout-from-ast (table pane (ast cleavir-ast:function-ast)) 67 | (let* ((children (cleavir-ast:children ast)) 68 | (reorganized (if (null children) '() 69 | (append (rest children) (list (first children)))))) 70 | (layout-from-ast-with-children table pane ast reorganized))) 71 | 72 | (defun make-layout (pane ast) 73 | (let ((table (make-hash-table :test #'eq))) 74 | (layout-from-ast table pane ast))) 75 | -------------------------------------------------------------------------------- /Abstract-syntax-tree/Visualizer/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-ast-visualizer 4 | (:use #:common-lisp) 5 | (:shadow #:position) 6 | (:export #:visualize)) 7 | -------------------------------------------------------------------------------- /Abstract-syntax-tree/cleavir-ast.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-ast 4 | :description "Abstract Syntax Tree representation for Common Lisp code." 5 | :author ("Robert Strandh " 6 | "Bike " 7 | "Charles Zhang") 8 | :maintainer "Bike " 9 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-ast/" 10 | :version "1.0.0" 11 | :license "BSD" 12 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 13 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 14 | :depends-on (:cleavir-io 15 | :cleavir-attributes) 16 | :serial t 17 | :components 18 | ((:file "packages") 19 | (:file "general-purpose-asts") 20 | (:file "graphviz-drawing") 21 | (:file "map-ast"))) 22 | -------------------------------------------------------------------------------- /Abstract-syntax-tree/map-ast.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-ast) 2 | 3 | (defun map-ast-depth-first-preorder (function ast) 4 | "Call FUNCTION on AST and all of its CHILDREN, in depth-first order." 5 | (labels ((visit (ast) 6 | (funcall function ast) 7 | (cleavir-ast:map-children #'visit ast))) 8 | (visit ast))) 9 | -------------------------------------------------------------------------------- /Abstract-syntax-tree/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-ast 4 | (:use #:common-lisp) 5 | (:shadow #:symbol #:ignore) 6 | (:export 7 | #:ast 8 | #:define-children #:children #:map-children 9 | #:source-info 10 | #:origin 11 | #:*policy* #:policy 12 | #:constant-ast #:make-constant-ast #:value 13 | #:lexical-bind-ast #:make-lexical-bind-ast #:ignore 14 | #:lexical-ast #:make-lexical-ast 15 | #:constant-dynamic-bind-ast 16 | #:set-constant-symbol-value-ast #:make-set-constant-symbol-value-ast 17 | #:symbol #:symbol-ast 18 | #:info #:name-ast 19 | #:constant-fdefinition-ast #:make-constant-fdefinition-ast #:info 20 | #:constant-symbol-value-ast #:make-constant-symbol-value-ast #:info 21 | #:call-ast #:make-call-ast #:callee-ast #:argument-asts 22 | #:inline-declaration #:attributes 23 | #:primop-ast 24 | #:block-ast #:make-block-ast #:body 25 | #:function-ast #:make-function-ast #:lambda-list 26 | #:bound-declarations #:docstring #:original-lambda-list 27 | #:top-level-function-ast #:make-top-level-function-ast #:forms 28 | #:body-ast 29 | #:inline-ast 30 | #:go-ast #:make-go-ast #:tag-ast 31 | #:if-ast #:make-if-ast #:test-ast #:then-ast #:else-ast 32 | #:branch-ast #:make-branch-ast #:branch-asts #:default-ast 33 | #:multiple-value-call-ast #:make-multiple-value-call-ast 34 | #:function-form-ast 35 | #:multiple-value-prog1-ast #:make-multiple-value-prog1-ast 36 | #:first-form-ast 37 | #:load-time-value-ast #:make-load-time-value-ast #:read-only-p 38 | #:form 39 | #:progn-ast #:make-progn-ast #:form-asts 40 | #:return-from-ast #:make-return-from-ast #:form-ast 41 | #:setq-ast #:make-setq-ast #:value-ast 42 | #:tagbody-ast #:make-tagbody-ast #:prefix-ast #:item-asts 43 | #:tag-ast #:make-tag-ast #:name 44 | #:unwind-protect-ast #:cleanup-ast 45 | #:the-ast #:make-the-ast #:ctype 46 | #:typeq-ast #:make-typeq-ast #:test-ctype 47 | #:type-check-function-ast 48 | #:eq-ast #:make-eq-ast #:arg1-ast #:arg2-ast 49 | #:case-ast #:make-case-ast #:arg-ast #:comparees 50 | #:lexical-variable #:make-lexical-variable 51 | #:unreachable-ast #:make-unreachable-ast 52 | #:child-ast 53 | #:map-ast-depth-first-preorder 54 | )) 55 | 56 | (defpackage #:cleavir-ast-graphviz 57 | (:use #:common-lisp #:cleavir-ast) 58 | (:shadowing-import-from #:cleavir-ast #:symbol #:ignore) 59 | (:export 60 | #:draw-ast)) 61 | -------------------------------------------------------------------------------- /Abstract-syntax-tree/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-ast)))) 4 | (mapcar #'find-package '("CLEAVIR-AST" "CLEAVIR-AST-GRAPHVIZ"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-ast)))) 7 | 'cleavir-page) 8 | 9 | (defmethod staple:subsystems ((sys (eql (asdf:find-system :cleavir-ast)))) 10 | ;; Without this method, Staple will think cleavir-ast-to-bir is a subsystem, since its 11 | ;; name starts with "cleavir-ast". 12 | ()) 13 | -------------------------------------------------------------------------------- /Attributes/README.md: -------------------------------------------------------------------------------- 1 | Data, especially functions, have many properties not expressible 2 | in the CL type system. For example: 3 | 4 | 1. whether their arguments can escape 5 | 2. whether they call their arguments 6 | 3. whether it can be constant folded, and how to do so 7 | 4. whether they escape from their defining context 8 | 5. how to determine the type of the return values from 9 | specifically some given argument types 10 | 6. how to rewrite a call to be more efficient given type, extent, 11 | or other information 12 | 13 | This subsystem encapsulates this information in an 14 | "attributes" object. These attributes can be stored in the 15 | environment (so that e.g. a compiler knows that AREF has no 16 | side effects) before making their way into ASTs and IR 17 | where they can be used to validate transformations. 18 | 19 | Attributes have a few differences from types. For the most part 20 | they are impossible to test at runtime. They can be propagated 21 | like types, and sometimes inferred like types, but usually 22 | a meet or join operation won't return information as interesting 23 | as that you might get from a type. 24 | 25 | For clients: You can use make-attributes to make attributes to 26 | return from CLEAVIR-ENV:FUNCTION-INFO etc. 27 | 28 | TODO: All of this stuff should be more client-customizable. 29 | Per-argument attributes might be good. 30 | 31 | # Flags 32 | 33 | A flag is a binary on-off indicating some known information about a function. 34 | 35 | Flags are generally organized so that their lack is the general case, i.e. if a flag is "positive" in that it enables transformations, it must be explicitly asserted. Another way of putting this is that a completely unknown function essentially has no flags. 36 | 37 | ## Currently available flags 38 | 39 | `:NO-CALL` means that the function does not increase the number of ways its arguments can be called. That is, it does not call them itself, and does not enable calls to occur in new ways (e.g. by storing an argument in a global variable, where anybody could call it later). This weird phrasing is because function arguments could do these things themselves `(e.g. (labels ((foo (x) (push (cons #'foo x) *calls*))) ...))` and this does not implicate the NO-CALL-ness of any function that is passed them as an argument. 40 | Implies DYN-CALL. 41 | 42 | `:DYN-CALL` means that the function can only increase the number of ways its arguments can be called with ways that call the argument in a dynamic environment substantially identical to that of the `DYN-CALL` function. For example, `(lambda (f) (funcall f))` could be `DYN-CALL`, but `(lambda (f x) (let ((*x* x)) (funcall f)))` could not, as it calls its argument f in a different dynamic environment. This implies that arguments are dx-safe (TODO: attributes for that) because if `f` was e.g. stored in a global it could later be called in arbitrary dynamic environments. 43 | 44 | `:DX-CALL` implies that the function's callable arguments do not escape. For example, the function `(lambda (f) (funcall f))` is `DX-CALL`, while `(lambda (f) f)` is not. FIXME: This is probably better expressed as a dynamic extent attribute on individual arguments. 45 | 46 | `:FLUSHABLE` means the function does not side-effect, and that calls to it can be deleted if the value of the call is not used. 47 | -------------------------------------------------------------------------------- /Attributes/cleavir-attributes.asd: -------------------------------------------------------------------------------- 1 | (in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-attributes 4 | :description "Information about values not encompassed by the type system." 5 | :author ("Bike ") 6 | :maintainer "Bike " 7 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-attributes/" 8 | :version "1.0.0" 9 | :license "BSD" 10 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 11 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 12 | :depends-on (:cleavir-io) 13 | :components 14 | ((:file "packages") 15 | (:file "flags" :depends-on ("packages")) 16 | (:file "attributes" :depends-on ("flags" "packages")))) 17 | -------------------------------------------------------------------------------- /Attributes/flags.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-attributes) 2 | 3 | ;;; We represent boolean flags as an integer bitfield. 4 | 5 | (defun make-flags (&rest flags) 6 | "Return computed flags, given a list of flag specifiers (keywords like :NO-CALL). 7 | 8 | See HAS-FLAG-P" 9 | (let ((result 0)) 10 | (dolist (flag flags) 11 | (let ((bits (ecase flag 12 | ((:no-call) #b11) 13 | ((:dyn-call) #b10) 14 | ((:dx-call) #b100) 15 | ((:flushable) #b1000)))) 16 | (setf result (logior result bits)))) 17 | result)) 18 | 19 | (defun sub-flags-p (flags1 flags2) (zerop (logandc2 flags1 flags2))) 20 | 21 | (defun meet-flags (flags1 flags2) (logand flags1 flags2)) 22 | (defun join-flags (flags1 flags2) (logior flags1 flags2)) 23 | 24 | (defun %has-flag-p (flags flag-name) 25 | (logbitp 26 | (ecase flag-name 27 | ((:no-call) 0) 28 | ((:dyn-call) 1) 29 | ((:dx-call) 2) 30 | ((:flushable) 3)) 31 | flags)) 32 | -------------------------------------------------------------------------------- /Attributes/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-attributes 4 | (:use #:common-lisp) 5 | (:export #:attributes #:attributes-designator #:default-attributes 6 | #:identities 7 | #:sub-attributes-p #:meet-attributes #:join-attributes) 8 | (:export #:make-flags #:has-flag-p)) 9 | -------------------------------------------------------------------------------- /Attributes/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-attributes)))) 4 | (list (find-package "CLEAVIR-ATTRIBUTES"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-attributes)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /BIR-builder/cleavir-bir-builder.asd: -------------------------------------------------------------------------------- 1 | (defsystem :cleavir-bir-builder 2 | :description "Helper system for constructing BIR." 3 | :author ("Bike " "Charles Zhang") 4 | :maintainer "Bike " 5 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-bir-builder/" 6 | :version "1.0.0" 7 | :license "BSD" 8 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 9 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 10 | :depends-on (:cleavir-bir) 11 | :components ((:file "packages") 12 | (:file "builder" :depends-on ("packages")))) 13 | -------------------------------------------------------------------------------- /BIR-builder/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cleavir-bir-builder 2 | (:use #:cl) 3 | (:local-nicknames (#:bir #:cleavir-bir) 4 | (#:set #:cleavir-set)) 5 | (:export #:inserter #:constant #:vcell #:fcell #:adjoin-variable) 6 | (:export #:begin #:proceed #:insert #:terminate) 7 | (:export #:make-iblock)) 8 | -------------------------------------------------------------------------------- /BIR-transformations/cleavir-bir-transformations.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-bir-transformations 4 | :depends-on (:cleavir-bir :cleavir-set 5 | :cleavir-attributes :cleavir-ctype) 6 | :components 7 | ((:file "packages") 8 | (:file "eliminate-come-froms" :depends-on ("packages")) 9 | (:file "process-captured-variables" :depends-on ("packages")) 10 | (:file "delete-temporary-variables" :depends-on ("packages")) 11 | (:file "interpolate-function" :depends-on ("eliminate-come-froms" 12 | "packages")) 13 | (:file "copy-function" :depends-on ("packages")) 14 | (:file "inline" :depends-on ("interpolate-function" "packages")) 15 | (:file "simple-unwind" :depends-on ("packages")) 16 | (:file "meta-evaluate" :depends-on ("packages")) 17 | (:file "generate-type-checks" :depends-on ("packages")))) 18 | -------------------------------------------------------------------------------- /BIR-transformations/delete-temporary-variables.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-bir-transformations) 2 | 3 | ;;; Attempt to optimize a variable. 4 | (defun optimize-variable (variable) 5 | ;; Unreferenced variable can be deleted. 6 | (when (set:empty-set-p (bir:readers variable)) 7 | (set:mapset nil #'bir:delete-instruction (bir:writers variable)))) 8 | 9 | (defun function-optimize-variables (function) 10 | (set:mapset nil #'optimize-variable (bir:variables function))) 11 | 12 | (defun module-optimize-variables (module) 13 | (bir:map-functions #'function-optimize-variables module)) 14 | -------------------------------------------------------------------------------- /BIR-transformations/eliminate-come-froms.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-bir-transformations) 2 | 3 | (defun come-from-eliminable-p (come-from) 4 | (set:empty-set-p (bir:unwinds come-from))) 5 | 6 | (defun eliminate-come-from (come-from) 7 | (let ((fore (bir:iblock come-from)) 8 | (normal-next (first (bir:next come-from)))) 9 | ;; Replace the instruction 10 | (bir:replace-terminator 11 | (make-instance 'bir:jump 12 | :inputs () :outputs () :next (list normal-next) 13 | :origin (bir:origin come-from) :policy (bir:policy come-from)) 14 | come-from) 15 | ;; Fix reachability 16 | (bir:compute-iblock-flow-order (bir:function fore)) 17 | ;; Merge if able 18 | ;; NOTE: It may be possible to merge blocks within the tagbody as well, 19 | ;; but it's slightly complicated to do so correctly while not merging 20 | ;; deleted iblocks, and anyway practically speaking meta-evaluate will 21 | ;; handle it. 22 | (loop while (bir:merge-successor-if-possible fore)))) 23 | 24 | (defun eliminate-come-froms (function) 25 | (set:doset (come-from (bir:come-froms function)) 26 | (when (come-from-eliminable-p come-from) 27 | (eliminate-come-from come-from)))) 28 | 29 | (defun module-eliminate-come-froms (module) 30 | (bir:map-functions #'eliminate-come-froms module)) 31 | -------------------------------------------------------------------------------- /BIR-transformations/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-bir-transformations 4 | (:use #:cl) 5 | (:local-nicknames (#:bir #:cleavir-bir) 6 | (#:set #:cleavir-set) 7 | (#:ctype #:cleavir-ctype) 8 | (#:attributes #:cleavir-attributes)) 9 | (:export #:module-eliminate-come-froms #:eliminate-come-froms) 10 | (:export #:module-optimize-variables #:function-optimize-variables) 11 | (:export #:simple-unwinding-p #:simple-dynenv-p) 12 | (:export #:find-module-local-calls 13 | #:interpolate-module-calls #:maybe-interpolate) 14 | (:export #:determine-function-environments) 15 | (:export #:determine-closure-extents) 16 | (:export #:determine-variable-extents) 17 | (:export #:meta-evaluate-module 18 | #:generate-type-check-function 19 | #:transform-call #:fold-call #:derive-return-type 20 | #:flushable-call-p) 21 | (:export #:module-generate-type-checks)) 22 | -------------------------------------------------------------------------------- /BIR-transformations/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-bir-transformations)))) 4 | 'cleavir-page) 5 | -------------------------------------------------------------------------------- /BIR/Visualizer/README.md: -------------------------------------------------------------------------------- 1 | ## Introduction 2 | 3 | *This system currently only works in SBCL* 4 | 5 | Usage: 6 | 7 | ```lisp 8 | (asdf:load-system "cleavir-bir-visualizer") 9 | (load ".../Cleavir/Environment/Examples/sbcl.lisp") 10 | (cleavir.bir.visualizer:run) 11 | ``` 12 | 13 | ![Screenshot of the BIR visualizer in use](screenshot.png) 14 | 15 | Then edit the form and/or change the optimization settings and watch the intermediate representations change. 16 | 17 | Click objects to expand and collapse. BIR blocks have context menu (right pointer button click) entries "Organize slots by class" and "Flat list of slots" which display the instance slots of the respective object an addition to the specialized default presentation. 18 | -------------------------------------------------------------------------------- /BIR/Visualizer/cleavir-bir-visualizer.asd: -------------------------------------------------------------------------------- 1 | (defsystem "cleavir-bir-visualizer" 2 | :description "A simple interactive visualizer for the BIR intermediate representation" 3 | :author "Jan Moringen " 4 | 5 | :version "0.1" 6 | :depends-on ("alexandria" 7 | 8 | "eclector-concrete-syntax-tree" 9 | 10 | "cleavir-cst-to-ast" 11 | "cleavir-ast-to-bir" 12 | "cleavir-bir" 13 | "cleavir-bir-transformations" 14 | 15 | "mcclim" 16 | "clouseau") 17 | :serial t 18 | :components ((:file "package") 19 | (:file "compile") 20 | (:file "inspect") 21 | (:file "application"))) 22 | -------------------------------------------------------------------------------- /BIR/Visualizer/compile.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir.bir.visualizer) 2 | 3 | ;;; Environment 4 | 5 | (defclass visualizer-environment () 6 | ((%environment :reader environment 7 | :initarg :environment) 8 | (%optimize :initarg :optimize 9 | :reader optimize*))) 10 | 11 | (defmethod cleavir-env:variable-info 12 | (sys (env visualizer-environment) symbol) 13 | (cleavir-env:variable-info sys (environment env) symbol)) 14 | 15 | (defmethod cleavir-env:function-info (sys (env visualizer-environment) (sym t)) 16 | (cleavir-env:function-info sys (environment env) sym)) 17 | 18 | (defmethod cleavir-env:declarations ((env visualizer-environment)) 19 | (cleavir-env:declarations (environment env))) 20 | 21 | (defmethod cleavir-env:type-expand ((env visualizer-environment) type) 22 | (cleavir-env:type-expand (environment env) type)) 23 | 24 | (defmethod cleavir-compilation-policy:policy-qualities append ((env visualizer-environment)) 25 | (loop :for (quality value) :in (optimize* env) 26 | :collect `(,quality (integer 0 3) ,value))) 27 | 28 | (defmethod cleavir-policy:compute-policy-quality 29 | (name optimize (environment visualizer-environment)) 30 | (cleavir-policy:compute-policy-quality name optimize (environment environment))) 31 | 32 | (defmethod cleavir-env:optimize-info ((environment visualizer-environment)) 33 | (let ((optimize (optimize* environment))) 34 | (make-instance 'cleavir-env:optimize-info 35 | :optimize optimize 36 | :policy (cleavir-policy:compute-policy 37 | optimize environment)))) 38 | 39 | ;;; 40 | 41 | (defun bir-transformations (system module transforms) 42 | (reduce (lambda (module transform) 43 | (if (consp transform) ; KLUDGE 44 | (funcall (first transform) module system) 45 | (funcall transform module)) ; not all transforms return the module 46 | module) 47 | transforms :initial-value module)) 48 | 49 | ;;; Form reading and hook into compiler 50 | 51 | (defun cst<-string (string) 52 | (eclector.concrete-syntax-tree:read-from-string string)) 53 | 54 | (defvar *global-environment*) 55 | (defvar *system*) 56 | 57 | (defun module<-cst (cst policy transforms) 58 | (let* ((system *system*) 59 | (output (make-string-output-stream)) 60 | (bir (let ((*standard-output* output) 61 | (*error-output* output) 62 | (*trace-output* output)) 63 | (let* ((environment (make-instance 'visualizer-environment 64 | :environment *global-environment* 65 | :optimize policy)) 66 | (ast (cleavir-cst-to-ast:cst-to-ast 67 | cst environment system))) 68 | (cleavir-ast-to-bir:compile-toplevel ast system)))) 69 | (module (bir:module bir)) 70 | (module (bir-transformations system module transforms))) 71 | (values module 72 | (let ((string (get-output-stream-string output))) 73 | (if (a:emptyp string) nil string)) 74 | (with-output-to-string (*standard-output*) 75 | (cleavir-bir-disassembler:display module))))) 76 | 77 | (defun module<-string (string policy transforms) 78 | (module<-cst (cst<-string string) policy transforms)) 79 | -------------------------------------------------------------------------------- /BIR/Visualizer/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:cleavir.bir.visualizer 2 | (:use 3 | #:cl) 4 | 5 | (:local-nicknames 6 | (#:a #:alexandria) 7 | 8 | (#:set #:cleavir-set) 9 | (#:bir #:cleavir-bir)) 10 | 11 | (:export 12 | #:run)) 13 | -------------------------------------------------------------------------------- /BIR/Visualizer/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/s-expressionists/Cleavir/325e7abf9b3caa6a0aa809e165e8877dab7a0846/BIR/Visualizer/screenshot.png -------------------------------------------------------------------------------- /BIR/Visualizer/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-bir-visualizer)))) 4 | 'cleavir-page) 5 | 6 | (defmethod staple:template ((sys (eql (asdf:find-system :cleavir-bir-visualizer)))) 7 | (asdf:system-relative-pathname (asdf:find-system :cleavir-documentation-generation) 8 | "main" :type "ctml")) 9 | 10 | (defmethod staple:images ((sys (eql (asdf:find-system :cleavir-bir-visualizer)))) 11 | (list (asdf:system-relative-pathname sys "screenshot.png"))) 12 | -------------------------------------------------------------------------------- /BIR/cleavir-bir.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-bir 4 | :description "Block-based Intermediate Representation for compiled Lisp code." 5 | :author ("Bike " "Charles Zhang") 6 | :maintainer "Bike " 7 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-bir/" 8 | :version "1.1.0" 9 | :license "BSD" 10 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 11 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 12 | :depends-on (:cleavir-primop :cleavir-set :cleavir-attributes 13 | :acclimation :cleavir-conditions :cleavir-ctype 14 | :concrete-syntax-tree) 15 | :components 16 | ((:file "packages") 17 | (:file "structure" :depends-on ("packages")) 18 | (:file "instructions" :depends-on ("structure" "packages")) 19 | (:file "map" :depends-on ("instructions" "structure" "packages")) 20 | (:file "conditions" :depends-on ("packages")) 21 | (:file "graph-modifications" 22 | :depends-on ("conditions" "map" "instructions" "structure" "packages")) 23 | (:file "verify" 24 | :depends-on ("map" "instructions" "structure" "packages")) 25 | (:file "disassemble" 26 | :depends-on ("map" "instructions" "structure" "packages")) 27 | (:file "condition-reporters-english" 28 | :depends-on ("disassemble" "conditions" "packages")))) 29 | -------------------------------------------------------------------------------- /BIR/conditions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-bir) 2 | 3 | (define-condition unused-variable (conditions:origin 4 | conditions:program-style-warning) 5 | ((%variable :initarg :variable :reader variable))) 6 | 7 | (define-condition type-conflict (conditions:program-warning) 8 | ((%derived-type :initarg :derived-type :reader derived-type) 9 | (%asserted-type :initarg :asserted-type :reader asserted-type) 10 | (%datum :initarg :datum :reader datum) 11 | (%asserted-by :initarg :asserted-by :reader asserted-by))) 12 | 13 | (defmethod conditions:origin ((condition type-conflict)) 14 | (origin (asserted-by condition))) 15 | 16 | ;;; BIR failing the verifier means that something is wrong with the compiler, 17 | ;;; not the source code. So this is NOT a program-error. 18 | (define-condition verification-failed (acclimation:condition error) 19 | ((%module :initarg :module :reader module) 20 | (%function-problems :initarg :function-problems :reader function-problems) 21 | (%module-problems :initarg :module-problems :reader module-problems))) 22 | 23 | ;;; Similarly, this indicates a problem in the verifier itself. 24 | (define-condition verification-error (acclimation:condition error) 25 | ((%module :initarg :module :reader module) 26 | (%original-condition :initarg :original-condition 27 | :reader original-condition))) 28 | -------------------------------------------------------------------------------- /BIR/map.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-bir) 2 | 3 | (defmacro do-functions ((function module) &body body) 4 | "Execute the BODY with FUNCTION bound to each function in MODULE. Arbitrary order." 5 | `(set:doset (,function (functions ,module)) ,@body)) 6 | 7 | (defun map-functions (f module) 8 | "Call F on each function in MODULE. Arbitrary order." 9 | (do-functions (function module) 10 | (funcall f function))) 11 | 12 | (defmacro do-iblocks ((iblock function &optional (direction :forward)) &body body) 13 | "Execute the BODY with IBLOCK bound to each iblock in FUNCTION. 14 | DIRECTION may be :FORWARD for forward flow order, or :BACKWARD for reverse flow order." 15 | (multiple-value-bind (from to) 16 | (ecase direction 17 | (:forward (values 'start '%next)) 18 | (:backward (values 'tail '%prev))) 19 | `(do ((,iblock (,from ,function) (,to ,iblock))) 20 | ((null ,iblock)) 21 | ,@body))) 22 | 23 | (defun map-iblocks (f function) 24 | "Call F on each iblock in FUNCTION, in forward flow order." 25 | (do-iblocks (iblock function) 26 | (funcall f iblock))) 27 | 28 | (defmacro do-iblock-instructions ((instruction iblock 29 | &optional (direction :forward)) 30 | &body body) 31 | "Execute the BODY with INSTRUCTION bound to each instruction in IBLOCK. 32 | DIRECTION may be :FORWARD or :BACKWARD." 33 | (multiple-value-bind (from to) 34 | (ecase direction 35 | (:forward (values 'start 'successor)) 36 | (:backward (values 'end 'predecessor))) 37 | `(do ((,instruction (,from ,iblock) (,to ,instruction))) 38 | ((null ,instruction) (values)) 39 | ,@body))) 40 | 41 | (defun map-iblock-instructions (f iblock) 42 | "Call F on each instruction in IBLOCK, in forward order." 43 | (check-type iblock iblock) 44 | (do-iblock-instructions (instruction iblock) 45 | (funcall f instruction))) 46 | 47 | (defun map-iblock-instructions-backwards (f iblock) 48 | "Call F on each instruction in IBLOCK, in backwards order." 49 | (check-type iblock iblock) 50 | (do-iblock-instructions (instruction iblock :backward) 51 | (funcall f instruction))) 52 | 53 | (defun map-local-instructions (f function) 54 | "Call F on all instructions owned by FUNCTION, in forward flow order." 55 | (do-iblocks (iblock function) 56 | (map-iblock-instructions f iblock))) 57 | 58 | (defun map-lambda-list (function lambda-list) 59 | "This utility parses BIR lambda lists. FUNCTION takes three arguments: The state of the parse (e.g. &OPTIONAL), the current lambda-list item being parsed, and the index of the item." 60 | (let ((state :required) 61 | (index 0)) 62 | (dolist (item lambda-list) 63 | (if (symbolp item) 64 | (setq state item) 65 | (progn 66 | (funcall function state item index) 67 | (incf index)))))) 68 | -------------------------------------------------------------------------------- /BIR/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-bir)))) 4 | 'cleavir-page) 5 | 6 | (defmethod staple:template ((sys (eql (asdf:find-system :cleavir-bir)))) 7 | (asdf:system-relative-pathname (asdf:find-system :cleavir-documentation-generation) 8 | "main" :type "ctml")) 9 | 10 | (defmethod staple:subsystems ((sys (eql (asdf:find-system :cleavir-bir)))) 11 | (list (asdf:find-system :cleavir-bir-visualizer))) 12 | 13 | (defmethod staple:images ((sys (eql (asdf:find-system :cleavir-bir)))) 14 | ;; Make sure none of the images from the visualizer are duplicated here. 15 | ()) 16 | 17 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-bir)))) 18 | (mapcar #'find-package '("CLEAVIR-BIR" "CLEAVIR-BIR-DISASSEMBLER"))) 19 | 20 | (defmethod staple:documents ((sys (eql (asdf:find-system :cleavir-bir)))) 21 | (list (asdf:system-relative-pathname sys "README" :type "md"))) 22 | -------------------------------------------------------------------------------- /CST-to-AST/Test/assign-sources.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast-test) 2 | 3 | (defun assign-sources (cst) 4 | (labels ((aux (cst path) 5 | (reinitialize-instance cst :source path) 6 | (when (cst:consp cst) 7 | (loop for i from 0 8 | for rest = cst then (cst:rest rest) 9 | until (cst:null rest) 10 | do (aux (cst:first rest) (append path (list i))))))) 11 | (aux cst '(0)))) 12 | -------------------------------------------------------------------------------- /CST-to-AST/Test/ast-equal-p.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast-test) 2 | 3 | (defun ast-equal-p (x y) 4 | (let ((table (make-hash-table :test #'equalp))) 5 | (flet ((report-difference (x y) 6 | (format *trace-output* 7 | "difference ~s ~s" x y))) 8 | (labels ((aux (x y) 9 | (cond ((gethash (cons x y) table) 10 | t) 11 | ((nth-value 1 (gethash (cons x y) table)) 12 | (report-difference x y) 13 | nil) 14 | ((not (eq (class-of x) (class-of y))) 15 | (report-difference x y) 16 | nil) 17 | ((and (typep x 'cleavir-ast:ast) 18 | (typep y 'cleavir-ast:ast)) 19 | (setf (gethash (cons x y) table) t) 20 | (setf (gethash (cons x y) table) 21 | (loop for save-info in (cleavir-io:save-info x) 22 | always (aux 23 | (funcall (cadr save-info) x) 24 | (funcall (cadr save-info) y))))) 25 | ((and (listp x) 26 | (listp y) 27 | (not (= (length x) (length y)))) 28 | (report-difference x y) 29 | nil) 30 | ((and (listp x) (listp y)) 31 | (setf (gethash (cons x y) table) t) 32 | (setf (gethash (cons x y) table) 33 | (loop for element1 in x 34 | for element2 in y 35 | always (aux element1 element2)))) 36 | ((and (symbolp x) 37 | (symbolp y)) 38 | (if (or (and (null (symbol-package x)) 39 | (null (symbol-package y))) 40 | (string= (symbol-name x) (symbol-name y))) 41 | t 42 | (progn (report-difference x y) nil))) 43 | ((not (equal x y)) 44 | (report-difference x y) nil) 45 | (t 46 | (setf (gethash (cons x y) table) t))))) 47 | (aux x y))))) 48 | -------------------------------------------------------------------------------- /CST-to-AST/Test/ast-from-string.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast-test) 2 | 3 | (defun ast-from-string (string) 4 | (let ((*readtable* cleavir-io:*io-readtable*) 5 | (cleavir-ast:*policy* nil)) 6 | (read-from-string string))) 7 | -------------------------------------------------------------------------------- /CST-to-AST/Test/cleavir-cst-to-ast-test.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem #:cleavir-cst-to-ast-test 4 | :depends-on (#:cleavir-cst-to-ast 5 | #:cleavir-ast-transformations 6 | #:cleavir-io) 7 | :serial t 8 | :components 9 | ((:file "packages") 10 | (:file "environment") 11 | (:file "ast-from-string") 12 | (:file "ast-equal-p") 13 | (:file "assign-sources") 14 | #+dont (:file "test" 15 | :around-compile 16 | (lambda (thunk) 17 | (progv (list '*readtable* 18 | (find-symbol "*POLICY*" (find-package "CLEAVIR-AST"))) 19 | (list (symbol-value (find-symbol "*IO-READTABLE*" (find-package "CLEAVIR-IO"))) 20 | nil) 21 | (funcall thunk))))) 22 | :perform (test-op (operation component) 23 | (uiop:symbol-call '#:cleavir-cst-to-ast-test '#:test))) 24 | -------------------------------------------------------------------------------- /CST-to-AST/Test/environment.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast-test) 2 | 3 | (defclass environment () ()) 4 | 5 | (defmethod cleavir-environment:optimize-info ((environment environment)) 6 | (make-instance 'cleavir-environment:optimize-info 7 | :optimize '((speed 0) (compilation-speed 0) (space 0) (debug 3) (safety 3)) 8 | :policy '())) 9 | 10 | (defmethod cleavir-environment:function-info 11 | ((environment environment) function-name) 12 | (cond ((or (and (symbolp function-name) 13 | (eq (symbol-package function-name) 14 | (find-package 'cleavir-primop)) 15 | (not (eq function-name 16 | 'cleavir-primop:call-with-variable-bound))) 17 | (and (symbolp function-name) 18 | (special-operator-p function-name))) 19 | (make-instance 'cleavir-environment:special-operator-info 20 | :name function-name)) 21 | ((and (symbolp function-name) 22 | (eq (symbol-package function-name) 23 | (find-package 'common-lisp)) 24 | (not (null (macro-function function-name)))) 25 | (make-instance 'cleavir-environment:global-macro-info 26 | :name function-name 27 | :expander (macro-function function-name) 28 | :compiler-macro nil)) 29 | ((and (symbolp function-name) 30 | (eq (symbol-package function-name) 31 | (find-package 'common-lisp)) 32 | (typep (ignore-errors (fdefinition function-name)) 'function)) 33 | (make-instance 'cleavir-environment:global-function-info 34 | :name function-name 35 | :dynamic-extent nil 36 | :ast nil 37 | :ignore nil 38 | :compiler-macro nil 39 | :inline nil 40 | :type t)) 41 | (t nil))) 42 | 43 | (defmethod cleavir-environment:variable-info ((environment environment) symbol) 44 | (if (member symbol '(*special1* *special2*)) 45 | (make-instance 'cleavir-environment:special-variable-info 46 | :global-p t 47 | :ignore nil 48 | :name symbol) 49 | nil)) 50 | 51 | (defmethod cleavir-environment:eval (form (env1 environment) (env2 environment)) 52 | (eval form)) 53 | -------------------------------------------------------------------------------- /CST-to-AST/Test/make-load-form.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast-test) 2 | 3 | (defmethod make-load-form ((object cleavir-ast:ast) &optional environment) 4 | (declare (ignore environment)) 5 | (cleavir-ast-transformations:codegen-clone-ast object)) 6 | -------------------------------------------------------------------------------- /CST-to-AST/Test/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-cst-to-ast-test 4 | (:use #:common-lisp) 5 | (:export)) 6 | -------------------------------------------------------------------------------- /CST-to-AST/cleavir-cst-to-ast.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-cst-to-ast 4 | :description "Compiler of source concrete syntax trees into abstract syntax trees." 5 | :author ("Robert Strandh " 6 | "Bike " 7 | "Charles Zhang") 8 | :maintainer ("Bike ") 9 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-cst-to-ast/" 10 | :version "1.0.0" 11 | :license "BSD" 12 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 13 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 14 | :depends-on (:concrete-syntax-tree 15 | :concrete-syntax-tree-destructuring 16 | :cleavir-ast 17 | :cleavir-primop 18 | :cleavir-environment 19 | :cleavir-compilation-policy 20 | :cleavir-ctype 21 | :cleavir-conditions 22 | :acclimation) 23 | :serial t 24 | :components 25 | ((:file "packages") 26 | (:file "conditions") 27 | (:file "condition-reporters-english") 28 | (:file "environment-augmentation") 29 | (:file "environment-query") 30 | (:file "variables") 31 | (:file "generic-functions") 32 | (:file "convert-function-reference") 33 | (:file "convert-special-binding") 34 | (:file "utilities") 35 | (:file "set-or-bind-variable") 36 | (:file "process-progn") 37 | (:file "convert-sequence") 38 | (:file "convert-variable") 39 | (:file "convert") 40 | (:file "process-init-parameter") 41 | (:file "itemize-declaration-specifiers") 42 | (:file "itemize-lambda-list") 43 | (:file "lambda-list-from-parameter-groups") 44 | (:file "convert-setq") 45 | (:file "convert-let-and-letstar") 46 | (:file "convert-code") 47 | (:file "convert-lambda-call") 48 | (:file "convert-constant") 49 | (:file "convert-special") 50 | (:file "convert-primop") 51 | (:file "convert-cst") 52 | (:file "cst-to-ast"))) 53 | -------------------------------------------------------------------------------- /CST-to-AST/convert-constant.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; CONVERT-CONSTANT is called when a constant is found, either in the 6 | ;;; form of a literal or in the form of a constant variable. 7 | 8 | (defun convert-constant (constant-cst env system) 9 | (declare (ignore env system)) 10 | (ast:make-constant-ast (cst:raw constant-cst) :origin constant-cst)) 11 | -------------------------------------------------------------------------------- /CST-to-AST/convert-function-reference.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | (defmethod convert-global-function-reference (cst info global-env system) 4 | (declare (ignore global-env system)) 5 | (ast:make-constant-fdefinition-ast 6 | (env:name info) 7 | :attributes (env:attributes info) :origin cst)) 8 | 9 | (defmethod convert-function-reference 10 | (cst (info env:global-function-info) env system) 11 | (convert-global-function-reference 12 | cst info (env:global-environment env) system)) 13 | 14 | (defmethod convert-function-reference 15 | (cst (info env:local-function-info) env system) 16 | (declare (ignore env system)) 17 | (ast:make-lexical-ast (env:identity info) :origin cst)) 18 | 19 | (defmethod convert-function-reference 20 | (cst (info env:global-macro-info) env system) 21 | (declare (ignore env system)) 22 | (error 'function-name-names-global-macro :cst cst)) 23 | 24 | (defmethod convert-function-reference 25 | (cst (info env:local-macro-info) env system) 26 | (declare (ignore env system)) 27 | (error 'function-name-names-local-macro :cst cst)) 28 | 29 | (defmethod convert-function-reference 30 | (cst (info env:special-operator-info) env system) 31 | (declare (ignore env system)) 32 | (error 'function-name-names-special-operator :cst cst)) 33 | 34 | ;;; These are used by (foo ...) forms. 35 | ;;; It's useful to distinguish them. For instance, an implementation 36 | ;;; may bind non-fbound symbols to a function that signals an error 37 | ;;; of type UNDEFINED-FUNCTION, allowing an fboundp check to be skipped. 38 | ;;; Other than the inlining, they by default have the same behavior. 39 | 40 | (defmethod convert-called-function-reference (cst info env system) 41 | (when (not (eq (env:inline info) 'cl:notinline)) 42 | (let ((ast (env:ast info))) 43 | (when ast 44 | (return-from convert-called-function-reference 45 | (make-instance 'ast:inline-ast 46 | :origin cst :body-ast ast))))) 47 | (convert-global-function-reference 48 | cst info (env:global-environment env) system)) 49 | 50 | (defmethod convert-called-function-reference 51 | (cst (info env:local-function-info) env system) 52 | (declare (ignore env system)) 53 | (ast:make-lexical-ast (env:identity info) :origin cst)) 54 | 55 | (defmethod convert-called-function-reference 56 | (cst (info env:global-macro-info) env system) 57 | (declare (ignore env system)) 58 | (error 'function-name-names-global-macro :cst cst)) 59 | 60 | (defmethod convert-called-function-reference 61 | (cst (info env:local-macro-info) env system) 62 | (declare (ignore env system)) 63 | (error 'function-name-names-local-macro :cst cst)) 64 | 65 | (defmethod convert-called-function-reference 66 | (cst (info env:special-operator-info) env system) 67 | (declare (ignore env system)) 68 | (error 'function-name-names-special-operator :cst cst)) 69 | -------------------------------------------------------------------------------- /CST-to-AST/convert-lambda-call.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Converting a compound form when the head of a compound form is a 6 | ;;; CONS. Then the head must be a lambda expression. We replace a 7 | ;;; call such as ((lambda (params) . body) . args) by (flet ((temp 8 | ;;; (params) . body)) (temp . args)) 9 | ;;; 10 | ;;; FIXME: do some more error checking. 11 | 12 | (defmethod convert-lambda-call (cst env system) 13 | (cst:db origin ((lambda-cst lambda-list-cst . body-cst) . args-cst) cst 14 | (assert (eql (cst:raw lambda-cst) 'cl:lambda) nil 15 | 'lambda-call-first-symbol-not-lambda :cst lambda-cst) 16 | (ast:make-call-ast 17 | (convert-code lambda-list-cst body-cst env system :origin cst) 18 | (convert-sequence args-cst env system) 19 | :origin cst))) 20 | -------------------------------------------------------------------------------- /CST-to-AST/convert-sequence.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | ;;; Utility function for converting a sequence of CSTs, represented 4 | ;;; as a chain of CONS-CSTs terminated by a NULL-CST. 5 | (defun convert-sequence (sequence-cst environment system) 6 | (loop for cst = sequence-cst then (cst:rest cst) 7 | until (cst:null cst) 8 | collect (convert (cst:first cst) environment system))) 9 | -------------------------------------------------------------------------------- /CST-to-AST/convert-setq.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Converting SETQ. 6 | 7 | (defmethod convert-setq 8 | (var-cst form-cst (info env:constant-variable-info) env system) 9 | (declare (ignore var-cst env system)) 10 | (error 'setq-constant-variable :cst form-cst)) 11 | 12 | (defmethod convert-setq 13 | (var-cst form-cst (info env:lexical-variable-info) env system) 14 | (ast:make-setq-ast (env:identity info) 15 | (type-wrap 16 | (convert form-cst env system) 17 | (env:type info) :setq var-cst env system) 18 | :origin var-cst)) 19 | 20 | (defmethod convert-setq 21 | (var-cst form-cst (info env:symbol-macro-info) env system) 22 | (let* ((expansion (env:expansion info)) 23 | (expander (symbol-macro-expander expansion)) 24 | (expanded-variable (expand-macro expander var-cst env)) 25 | (expanded-cst (cst:reconstruct system expanded-variable var-cst 26 | :default-source var-cst)) 27 | (origin (cst:source var-cst))) 28 | (convert (cst:quasiquote origin 29 | (setf (cst:unquote expanded-cst) 30 | ;; FIXME: wrap declared type 31 | (cst:unquote form-cst))) 32 | env system))) 33 | 34 | (defmethod convert-setq-special-variable 35 | (var-cst form-ast info global-env system) 36 | (declare (ignore global-env system)) 37 | (let ((temp (ast:make-lexical-variable (gensym) :origin var-cst))) 38 | (process-progn 39 | (list (ast:make-lexical-bind-ast temp form-ast :origin var-cst) 40 | (ast:make-set-constant-symbol-value-ast 41 | (env:name info) 42 | (ast:make-lexical-ast temp :origin var-cst) 43 | :origin var-cst) 44 | (ast:make-lexical-ast temp :origin var-cst)) 45 | var-cst))) 46 | 47 | (defmethod convert-setq 48 | (var-cst form-cst (info env:special-variable-info) env system) 49 | (let ((global-env (env:global-environment env))) 50 | (convert-setq-special-variable var-cst 51 | (type-wrap 52 | (convert form-cst env system) 53 | (env:type info) :setq var-cst env system) 54 | info 55 | global-env 56 | system))) 57 | 58 | (defun convert-elementary-setq (var-cst form-cst env system) 59 | (convert-setq var-cst form-cst (variable-info system env var-cst) env system)) 60 | -------------------------------------------------------------------------------- /CST-to-AST/convert-special-binding.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | (defmethod convert-special-binding 4 | (variable-cst value-ast next-ast env system) 5 | (declare (ignore env system)) 6 | (make-instance 'ast:constant-dynamic-bind-ast 7 | :name (cst:raw variable-cst) 8 | :value-ast value-ast 9 | :body-ast next-ast 10 | :origin variable-cst)) 11 | -------------------------------------------------------------------------------- /CST-to-AST/convert-variable.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | (defmethod convert-variable (cst environment system) 4 | (convert-cst cst (variable-info system environment cst) environment system)) 5 | -------------------------------------------------------------------------------- /CST-to-AST/convert.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; CONVERT is responsible for converting a concrete syntax tree to an 6 | ;;; abstract syntax tree. 7 | 8 | (defmethod convert (cst environment system) 9 | (let ((form (cst:raw cst))) 10 | (cond ((and (not (consp form)) (not (symbolp form))) 11 | (convert-constant cst environment system)) 12 | ((symbolp form) 13 | (convert-variable cst environment system)) 14 | ((symbolp (car form)) 15 | ;; Even if we are in COMPILE-TIME-TOO mode, at this point, we 16 | ;; do not know whether to evaluate the form at compile time, 17 | ;; simply because it might be a special form that is handled 18 | ;; specially. So we must wait until we have more 19 | ;; information. 20 | (let ((info (function-info system environment (cst:first cst)))) 21 | (convert-cst cst info environment system))) 22 | (t 23 | ;; The form must be a compound form where the CAR is a lambda 24 | ;; expression. Evaluating such a form might have some 25 | ;; compile-time side effects, so we must check whether we are 26 | ;; in COMPILE-TIME-TOO mode, in which case we must evaluate 27 | ;; the form as well. 28 | (when (and *current-form-is-top-level-p* *compile-time-too*) 29 | (cst-eval-for-effect cst environment system)) 30 | (convert-lambda-call cst environment system))))) 31 | 32 | (defmethod convert :around (cst environment system) 33 | (restart-case 34 | ;; We bind these only here so that if a restart is invoked, 35 | ;; the new CONVERT call will get the right values 36 | ;; (i.e., the ones outside our binding) 37 | (let ((*current-form-is-top-level-p* *subforms-are-top-level-p*) 38 | (*subforms-are-top-level-p* nil) 39 | ;; gives all generated ASTs the appropriate policy. 40 | (ast:*policy* (env:environment-policy environment))) 41 | (call-next-method)) 42 | (continue () 43 | :report "Replace with call to ERROR." 44 | (convert (cst:cst-from-expression 45 | `(error 'run-time-program-error 46 | :expr ',(cst:raw cst) 47 | :origin ',(cst:source cst)) 48 | :source (cst:source cst)) 49 | environment system)) 50 | (substitute-cst (cst) 51 | :report "Compile the given CST in place of the problematic one." 52 | (convert cst environment system)))) 53 | -------------------------------------------------------------------------------- /CST-to-AST/cst-to-ast.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | ;;; This variable should be bound by client code to one of the symbols 4 | ;;; CL:COMPILE, CL:COMPILE-FILE, or CL:EVAL before the main entry 5 | ;;; point is called. 6 | (defvar *compiler*) 7 | 8 | (defun cst-to-ast (cst environment system) 9 | (let ((*subforms-are-top-level-p* t) 10 | (*compile-time-too* nil)) 11 | (convert cst environment system))) 12 | -------------------------------------------------------------------------------- /CST-to-AST/itemize-declaration-specifiers.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | ;;;; Recall that a canonical declaration specifier is an ordinary 4 | ;;;; Common Lisp list containing two CSTs, the first one representing 5 | ;;;; a declaration identifier and the second one representing a single 6 | ;;;; declaration datum such as the name of a variable. 7 | 8 | ;;; Separate a list of canonical declaration specifiers into two 9 | ;;; disjoint sets, returned as two values. The first set contains All 10 | ;;; the declerations specifiers that concern an ordinary variable 11 | ;;; named NAME, and the second set the remaining declaration 12 | ;;; specifiers. 13 | (defun separate-declarations (canonical-declaration-specifiers name-cst) 14 | (loop with name = (cst:raw name-cst) 15 | for spec in canonical-declaration-specifiers 16 | for declaration-identifier = (cst:raw (cst:first spec)) 17 | if (or (and (member declaration-identifier 18 | '(ignore ignorable dynamic-extent special)) 19 | (eq (cst:raw (cst:second spec)) name)) 20 | (and (eq declaration-identifier 'type) 21 | (eq (cst:raw (cst:third spec)) name))) 22 | collect spec into first 23 | else 24 | collect spec into second 25 | finally (return (values first second)))) 26 | 27 | ;;; This function takes two arguments. The first argument, VARIABLES, 28 | ;;; is a list of items, where each item is a non-empty list of CSTs. 29 | ;;; The CSTs in an item represent the variables that are bound in a 30 | ;;; single binding in a lambda list. The second argument, 31 | ;;; CANONICAL-DSPECS, is a list of canonical declaration specifiers. 32 | ;;; This function returns a two values. The first return value is a 33 | ;;; list with the same shape as VARIABLES. For each variable-cst in 34 | ;;; VARIABLES, this return value has a list of elements in 35 | ;;; CANONICAL-DSPECS that apply to that variable. The second 36 | ;;; return value is a list of the remaining declaration specifiers in 37 | ;;; CANONICAL-DSPECS i.e. the ones that do not apply to any element in 38 | ;;; VARIABLES. A particular symbol S can not appear twice in an item 39 | ;;; of VARIABLES, but it can appear in different items. In that case, 40 | ;;; the declaration specifiers that apply to that symbol will be 41 | ;;; associated with the last item in the list of VARIABLES. 42 | (defun itemize-declaration-specifiers (variables canonical-dspecs) 43 | (if (null variables) 44 | (values '() canonical-dspecs) 45 | (multiple-value-bind (itemized-dspecs remaining-dspecs) 46 | (itemize-declaration-specifiers (rest variables) canonical-dspecs) 47 | (values 48 | (cons 49 | (loop for var in (first variables) 50 | collect (multiple-value-bind (is-dspecs r-dspecs) 51 | (separate-declarations remaining-dspecs var) 52 | (setf remaining-dspecs r-dspecs) 53 | is-dspecs)) 54 | itemized-dspecs) 55 | remaining-dspecs)))) 56 | -------------------------------------------------------------------------------- /CST-to-AST/itemize-lambda-list.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | (defmethod items-from-parameter-group 4 | ((parameter-group cst:ordinary-required-parameter-group)) 5 | (loop for parameter in (cst:parameters parameter-group) 6 | collect (list (cst:name parameter)))) 7 | 8 | (defmethod items-from-parameter-group 9 | ((parameter-group cst:ordinary-optional-parameter-group)) 10 | (loop for parameter in (cst:parameters parameter-group) 11 | for name = (cst:name parameter) 12 | for supplied-p = (cst:supplied-p parameter) 13 | collect (if (null supplied-p) 14 | (list name) 15 | (list name supplied-p)))) 16 | 17 | (defmethod items-from-parameter-group 18 | ((parameter-group cst:ordinary-rest-parameter-group)) 19 | (list (list (cst:name (cst:parameter parameter-group))))) 20 | 21 | (defmethod items-from-parameter-group 22 | ((parameter-group cst:ordinary-key-parameter-group)) 23 | (loop for parameter in (cst:parameters parameter-group) 24 | for name = (cst:name parameter) 25 | for supplied-p = (cst:supplied-p parameter) 26 | collect (if (null supplied-p) 27 | (list name) 28 | (list name supplied-p)))) 29 | 30 | (defmethod items-from-parameter-group 31 | ((parameter-group cst:aux-parameter-group)) 32 | (loop for parameter in (cst:parameters parameter-group) 33 | collect (list (cst:name parameter)))) 34 | 35 | ;;; Given a parsed lambda list, return a list of items. There are as 36 | ;;; many items in the list as there are bindings in the lambda list. 37 | ;;; In this case, an occurrence of a parameter together with a 38 | ;;; supplied-p parameter is considered to be a single item. Each item 39 | ;;; is a list of one or two CSTs. For a parameter with an associated 40 | ;;; supplied-p parameter, the item contains the CSTs for both the 41 | ;;; parameter and the associated supplied-p parameter. Otherwise, the 42 | ;;; item contains just the CST for the parameter. 43 | (defun itemize-lambda-list (parsed-lambda-list) 44 | (loop for parameter-group in (cst:children parsed-lambda-list) 45 | collect (items-from-parameter-group parameter-group))) 46 | -------------------------------------------------------------------------------- /CST-to-AST/process-init-parameter.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | ;;; VAR and SUPPLIED-P are LEXICAL-VARIABLEs representing a parameter 4 | ;;; variable and its associated SUPPLIED-P variable. If no associated 5 | ;;; SUPPLIED-P variable is present in the lambda list then 6 | ;;; SUPPLIED-P-CST is NIL. INIT-AST is the AST that computes the 7 | ;;; value to be assigned to the variable represented by VAR-CST if no 8 | ;;; argument was supplied for it. ENV is an environment that already 9 | ;;; contains the variables corresponding to VAR-CST and SUPPLIED-P-CST 10 | ;;; (if it is not NIL). 11 | 12 | ;;; This function returns an AST that represents processing of this 13 | ;;; parameter and the next computation. 14 | (defun process-init-parameter 15 | (var-cst var supplied-p-cst supplied-p init-ast env next-ast system) 16 | (let* ((origin (cst:source var-cst)) 17 | (next-ast 18 | (set-or-bind-variable 19 | var-cst 20 | (ast:make-if-ast 21 | (ast:make-eq-ast 22 | ;; The reason we switch to the bound supplied variable 23 | ;; is so that we can keep the use of the argument 24 | ;; supplied-p linear for the sake of making the BIR much 25 | ;; simpler, as arguments in BIR are linear data. 26 | (if supplied-p-cst 27 | (convert-variable supplied-p-cst env system) 28 | (ast:make-lexical-ast supplied-p :origin var-cst)) 29 | (convert-constant (make-atom-cst nil origin) env system) 30 | :origin var-cst) 31 | init-ast 32 | (ast:make-lexical-ast var :origin var-cst) 33 | :origin var-cst) 34 | next-ast 35 | env system))) 36 | (if (null supplied-p-cst) 37 | next-ast 38 | (set-or-bind-variable supplied-p-cst 39 | (ast:make-lexical-ast supplied-p :origin var-cst) 40 | next-ast 41 | env 42 | system)))) 43 | -------------------------------------------------------------------------------- /CST-to-AST/process-progn.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Turn a list of ASTs into either a PROGN-AST, the unique AST in the 6 | ;;; list if it has only one AST, or a CONSTANT-AST containing NIL in 7 | ;;; case the list of ASTs is NIL. 8 | 9 | (defun process-progn (asts &optional origin) 10 | (cond ((null asts) (ast:make-constant-ast nil :origin origin)) 11 | ((null (rest asts)) (first asts)) 12 | (t (ast:make-progn-ast asts :origin origin)))) 13 | -------------------------------------------------------------------------------- /CST-to-AST/set-or-bind-variable.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | ;;; ENV is an environment that is known to contain information about 4 | ;;; the variable VARIABLE, but we don't know whether it is special or 5 | ;;; lexical. VALUE-AST is an AST that computes the value to be given 6 | ;;; to VARIABLE. NEXT-AST is an AST that represents the computation 7 | ;;; to take place after the variable has been given its value. If the 8 | ;;; variable is special, this function creates a BIND-AST with 9 | ;;; NEXT-AST as its body. If the variable is lexical, this function 10 | ;;; creates a PROGN-AST with two ASTs in it. The first one is a 11 | ;;; LEXICAL-BIND-AST that assigns the value to the variable, and the second 12 | ;;; one is the NEXT-AST. 13 | (defun set-or-bind-variable (variable-cst value-ast next-ast env system) 14 | (let* ((info (env:variable-info system env (cst:raw variable-cst))) 15 | (_ (assert (not (null info)))) 16 | ;; Type wrap the value. Per CLHS 3.3.4 "Declaration Scope" 17 | ;; bound declarations do apply to the initial value of the binding. 18 | ;; (The page on the TYPE declaration also specifically says it 19 | ;; applies to the initial values of bindings.) 20 | (value-ast 21 | (type-wrap value-ast (env:type info) 22 | :setq (ast:origin value-ast) env system))) 23 | (declare (ignore _)) 24 | (if (typep info 'env:special-variable-info) 25 | (convert-special-binding 26 | variable-cst value-ast next-ast env system) 27 | (ast:make-progn-ast 28 | (list (ast:make-lexical-bind-ast 29 | (env:identity info) 30 | value-ast 31 | :origin variable-cst 32 | :ignore (env:ignore info)) 33 | next-ast) 34 | :origin variable-cst)))) 35 | -------------------------------------------------------------------------------- /CST-to-AST/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-cst-to-ast)))) 4 | (list (find-package "CLEAVIR-CST-TO-AST"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-cst-to-ast)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /CST-to-AST/variables.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-cst-to-ast) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Managing top-level forms. 6 | ;;; 7 | ;;; We need to be able to test whether a form is a top-level form or 8 | ;;; not. A few special forms (LOCALLY, MACROLET, SYMBOL-MACROLET) 9 | ;;; preserve this property in that if the special form itself is a 10 | ;;; top-level form, then the body of the special form is also a 11 | ;;; top-level form. For all other forms, any subform of the form is 12 | ;;; not considered a top-level form. 13 | 14 | ;;; The reason for the following somewhat twisted logic is that we 15 | ;;; want to avoid having to explicitly set *SUBFORMS-ARE-TOP-LEVEL-P* 16 | ;;; to false in every method EXCEPT the ones for LOCALLY, MACROLET, 17 | ;;; and SYMBOL-MACROLET. This logic allows us to add some code ONLY 18 | ;;; to these special forms in order to indicate that they preserve the 19 | ;;; top-level property. 20 | ;;; 21 | ;;; The way this logic works is as follows: We define a second 22 | ;;; variable named *CURRENT-FORM-IS-TOP-LEVEL-P*. This variable holds 23 | ;;; the value of *SUBFORMS-ARE-TOP-LEVEL-P* as it was before CONVERT was 24 | ;;; called, and this is the variable that we actually test in order to 25 | ;;; determine whether a form is a top-level form. To obtain that, we 26 | ;;; define an :AROUND method on CONVERT that binds 27 | ;;; *CURRENT-FORM-IS-TOP-LEVEL-P* to the value of *SUBFORMS-ARE-TOP-LEVEL-P* 28 | ;;; for the duration of the invocation of the primary method on 29 | ;;; CONVERT, and that also binds *SUBFORMS-ARE-TOP-LEVEL-P* to false. Any 30 | ;;; recursive invocation of CONVERT will thus automatically see the 31 | ;;; value of *CURRENT-FORM-IS-TOP-LEVEL-P* as false. The methods for 32 | ;;; LOCALLY, MACROLET, and SYMBOL-MACROLET set 33 | ;;; *CURRENT-FORM-IS-TOP-LEVEL-P* to true so that when they 34 | ;;; recursively call CONVERT, then this true value will be the value 35 | ;;; of *CURRENT-FORM-IS-TOP-LEVEL-P*. I hope this explanation makes 36 | ;;; sense. 37 | 38 | ;;; This variable is true if and only if the current form is a 39 | ;;; top-level form. 40 | (defvar *current-form-is-top-level-p*) 41 | 42 | ;;; This variable is true if and only if the subforms of the current 43 | ;;; form are top-level forms. 44 | (defvar *subforms-are-top-level-p*) 45 | 46 | (defmacro with-preserved-toplevel-ness (&body body) 47 | `(progn (setf *subforms-are-top-level-p* *current-form-is-top-level-p*) 48 | ,@body)) 49 | 50 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | ;;; 52 | ;;; Variables that control certain behavior of the compiler. 53 | 54 | ;;; This variable should be bound by client code to one of the symbols 55 | ;;; CL:COMPILE, CL:COMPILE-FILE, or CL:EVAL before the main entry 56 | ;;; point is called. 57 | (defvar *compiler*) 58 | 59 | ;;; This variable indicates whether a form should be evaluated in 60 | ;;; addition to be being processed by the compiler. 61 | (defvar *compile-time-too*) 62 | -------------------------------------------------------------------------------- /Compilation-policy/README.md: -------------------------------------------------------------------------------- 1 | Lisp has `OPTIMIZE` declarations for expressing that some 2 | lexical block should be compiled with an emphasis on "speed", 3 | and stuff like that. That's nice, but in the compiler's view, 4 | vague. This system converts `OPTIMIZE` information into specific 5 | and actionable "policies" for the rest of the compiler. 6 | 7 | Policies are separate objects computed from the optimize info. 8 | A policy consists of several "qualities", which are just a 9 | symbol naming it and a value. Qualities are computed from the 10 | generic function `COMPUTE-POLICY-QUALITY`, which is called from 11 | the overall `COMPUTE-POLICY` function. 12 | 13 | What policies exist is defined by the `POLICY-QUALITIES` 14 | generic function. Cleavir defines several of its own policies 15 | with `DEFINE-CLEAVIR-COMPILER-POLICY`, but implementations can 16 | as well for their own compiler transforms. `POLICY-QUALITIES`'s 17 | return value has the same format as 18 | `CLEAVIR-ENV:OPTIMIZE-QUALITIES`, and an `APPEND` method combo. 19 | 20 | Every AST and instruction stores the policy that was computed 21 | for its lexical region. (This means that policies should be 22 | kept cached.) When a compiler transform wants to know whether 23 | it should do something to such an object, it checks the 24 | `POLICY-VALUE` for whatever it's doing. 25 | 26 | For implementors: 27 | 28 | 1. If you have your own policies, return something from 29 | `POLICY-QUALITIES` when specified on your global environment. 30 | If you don't have your own policies don't sweat it. 31 | 2. Define a method for `COMPUTE-POLICY-QUALITY` specialized on 32 | each policy quality (including cleavir's) and your global 33 | environment. Example: 34 | 35 | ```lisp 36 | (defmethod cleavir-policy:compute-policy-quality 37 | ((name (eql 'cleavir-typed-transforms:insert-type-checks)) 38 | optimize (env sys:global-environment)) 39 | (= (cleavir-policy:optimize-value optimize 'safety) 3)) 40 | ``` 41 | 42 | 3. Make sure your environments respect the optimize info 43 | protocols in cleavir/environment. You can use 44 | COMPUTE-POLICY to compute policies from optimize decls, but 45 | you should avoid doing this on every optimize-info call. 46 | -------------------------------------------------------------------------------- /Compilation-policy/cleavir-compilation-policy.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | ;;;; Conceptual summary: 4 | (defsystem :cleavir-compilation-policy 5 | :description "System for representing and interrogating compiler policies." 6 | :author ("Robert Strandh " 7 | "Bike ") 8 | :maintainer "Bike " 9 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-compilation-policy/" 10 | :version "1.0.0" 11 | :license "BSD" 12 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 13 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 14 | :depends-on (:cleavir-environment :acclimation) 15 | :serial t 16 | :components 17 | ((:file "packages") 18 | (:file "conditions") 19 | (:file "condition-reporters-english") 20 | (:file "policy") 21 | (:file "define-policy") 22 | (:file "optimize") 23 | (:file "compute"))) 24 | -------------------------------------------------------------------------------- /Compilation-policy/compute.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-compilation-policy) 2 | 3 | ;;; Compute the value of a policy quality based on OPTIMIZE info. 4 | ;;; ENVIRONMENT is global and used for system dispatch. 5 | ;;; NAME is the name of the quality. 6 | ;;; Should return the value. 7 | (defgeneric compute-policy-quality (name optimize environment) 8 | (:argument-precedence-order name environment optimize)) 9 | 10 | ;;; If a policy is directly specified, just use that. 11 | (defmethod compute-policy-quality :around 12 | (name optimize environment) 13 | (declare (ignore environment)) 14 | (multiple-value-bind (value present-p) 15 | (optimize-value optimize name) 16 | (if present-p 17 | value 18 | (call-next-method)))) 19 | 20 | (defmethod compute-policy-quality (name optimize environment) 21 | (declare (ignore optimize)) 22 | (error 'no-policy-computer :quality name :env environment)) 23 | 24 | ;;; Compute the entire policy for given OPTIMIZE info. 25 | ;;; ENVIRONMENT is global and used for system dispatch. 26 | ;;; This is a generic so that in the future an implementation could 27 | ;;; hypothetically override the whole process; however, doing so 28 | ;;; would take more understanding of POLICY objects than is 29 | ;;; presently external. 30 | (defgeneric compute-policy (optimize environment) 31 | (:argument-precedence-order environment optimize)) 32 | 33 | ;;; Default method for the usual case of the implementation not 34 | ;;; overriding the entire process. 35 | (defmethod compute-policy (optimize environment) 36 | (let ((policy-qualities (policy-qualities environment)) 37 | (optimize (normalize-optimize optimize environment))) 38 | ;; uses representation of policies as alists 39 | (loop for (name) in policy-qualities ; ignore CDR 40 | collect (cons name (compute-policy-quality 41 | name optimize environment))))) 42 | -------------------------------------------------------------------------------- /Compilation-policy/condition-reporters-english.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-compilation-policy) 2 | 3 | (defmethod acclimation:report-condition 4 | ((condition bad-optimize-value) stream (language acclimation:english)) 5 | (format stream "Ignoring bad optimize value for ~s: ~s~@ 6 | Expected ~s" 7 | (first (specifier condition)) 8 | (second (specifier condition)) 9 | (expected-type condition))) 10 | 11 | (defmethod acclimation:report-condition 12 | ((condition unknown-optimize-quality) stream (language acclimation:english)) 13 | (format stream "Ignoring unknown OPTIMIZE quality ~s" 14 | (first (specifier condition)))) 15 | 16 | (defmethod acclimation:report-condition 17 | ((condition no-policy-computer) stream (language acclimation:english)) 18 | (format stream "~s is a defined policy quality for ~s, but there~@ 19 | is no method on COMPUTE-POLICY-QUALITY for it." 20 | (quality condition) (environment condition))) 21 | -------------------------------------------------------------------------------- /Compilation-policy/conditions.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-compilation-policy) 2 | 3 | (define-condition bad-optimize-value 4 | (warning acclimation:condition) 5 | ((%specifier :initarg :specifier :reader specifier) 6 | (%expected-type :initarg :expected :reader expected-type))) 7 | 8 | (define-condition unknown-optimize-quality 9 | (warning acclimation:condition) 10 | ((%specifier :initarg :specifier :reader specifier))) 11 | 12 | (define-condition no-policy-computer 13 | (error acclimation:condition) 14 | ((%quality :initarg :quality :reader quality) 15 | (%environment :initarg :env :reader environment))) 16 | -------------------------------------------------------------------------------- /Compilation-policy/define-policy.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-compilation-policy) 2 | 3 | ;;; Public interface. Given an environment return the available 4 | ;;; policy-qualities in that environment. The returned value has is a 5 | ;;; proper list of entries of the form (NAME TYPE DEFAULT), where NAME 6 | ;;; is the name of the quality, TYPE is the type of allowable values 7 | ;;; of the policy, and DEFAULT is the value used for a declaration 8 | ;;; like (OPTIMIZE NAME). 9 | (defgeneric policy-qualities (environment) 10 | (:method-combination append)) 11 | 12 | ;;; Private. A list to return from policy-qualities's default 13 | ;;; method: policies cleavir itself defines. Defined by 14 | ;;; DEFINE-CLEAVIR-POLICY-QUALITY. 15 | ;;; If an implementation wants to define its own policy qualities, 16 | ;;; it should specialize POLICY-QUALITIES. 17 | (defvar *cleavir-policy-qualities* nil) 18 | 19 | ;;; Default method. If global, use cleavir's. If not, jump up. 20 | (defmethod policy-qualities append (environment) 21 | ;; FIXME 22 | (let ((global (cleavir-env:global-environment environment))) 23 | (if (eq global environment) 24 | *cleavir-policy-qualities* 25 | (policy-qualities global)))) 26 | 27 | ;;; Define a cleavir policy quality, respecting redefinition. 28 | (defun make-cleavir-policy-quality (name type default) 29 | (unless (typep default type) 30 | ;; FIXME: could be an error, but this is just a sanity check 31 | ;; anyway 32 | (warn 'bad-optimize-value :specifier `(,name ,default) 33 | :expected type)) 34 | (let ((a (assoc name *cleavir-policy-qualities*))) 35 | (if (null a) 36 | (push (list name type default) *cleavir-policy-qualities*) 37 | (setf (rest a) (list type default))) 38 | name)) 39 | 40 | ;;; Defines a cleavir policy quality. This way the definition can 41 | ;;; go in the actual system (type inference defines relevant type 42 | ;;; inference policies, that sorta thing). 43 | (defmacro define-cleavir-policy-quality (name type default) 44 | `(make-cleavir-policy-quality ',name ',type ',default)) 45 | -------------------------------------------------------------------------------- /Compilation-policy/optimize.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-compilation-policy) 2 | 3 | ;;; Given a normalized OPTIMIZE declaration specifier, get the 4 | ;;; value of a quality, with return value like GETHASH. 5 | 6 | (defun optimize-value (optimize quality) 7 | (let ((a (assoc quality optimize))) 8 | (if a 9 | (values (second a) t) 10 | (values nil nil)))) 11 | 12 | ;;; Given an OPTIMIZE declaration specifier in code, return a 13 | ;;; normalized specification, so that (optimize space) becomes 14 | ;;; (optimize (space 3)). Additionally check that all qualities are 15 | ;;; known and have allowed values. 16 | (defgeneric normalize-optimize (optimize environment) 17 | (:argument-precedence-order environment optimize)) 18 | 19 | (defmethod normalize-optimize (optimize environment) 20 | (let* ((optimize-qualities 21 | (cleavir-environment:optimize-qualities environment)) 22 | (policy-qualities ; policies can also be provided directly 23 | (policy-qualities environment)) 24 | (all-qualities 25 | (append optimize-qualities policy-qualities)) 26 | normalized) 27 | (flet ((collect (spec) 28 | ;; only collect the first of each quality. 29 | (pushnew spec normalized :key #'car))) 30 | ;; use a DOLIST instead of LOOP because it gets tricky with 31 | ;; all the nested conditionals and collecting. 32 | (dolist (spec optimize normalized) 33 | (if (consp spec) ; like (optimize (speed 3)) 34 | (destructuring-bind (name value) spec 35 | (let ((info (assoc name all-qualities))) 36 | (if info 37 | (destructuring-bind (name type default) info 38 | (declare (ignore name default)) 39 | (if (typep value type) 40 | (collect spec) 41 | ;; TODO: add more restarts? This will 42 | ;; just ignore the bad spec. 43 | (warn 'bad-optimize-value 44 | :specifier spec 45 | :expected type))) 46 | (warn 'unknown-optimize-quality 47 | :specifier spec)))) 48 | ;; like (optimize speed) 49 | (let ((info (assoc spec all-qualities))) 50 | (if info 51 | (destructuring-bind (name type default) info 52 | (declare (ignore name type)) 53 | (collect (list spec default))) 54 | (warn 'unknown-optimize-quality 55 | :specifier spec)))))))) 56 | -------------------------------------------------------------------------------- /Compilation-policy/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-compilation-policy 4 | (:use #:common-lisp) 5 | (:nicknames #:cleavir-policy) 6 | (:export #:policy-value) 7 | (:export #:policy-qualities #:define-cleavir-policy-quality) 8 | (:export #:optimize-value #:normalize-optimize) 9 | (:export #:compute-policy #:compute-policy-quality)) 10 | -------------------------------------------------------------------------------- /Compilation-policy/policy.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-compilation-policy) 2 | 3 | (defun policy-value (policy quality) 4 | ;; policies are assumed to be complete 5 | (cdr (assoc quality policy))) 6 | -------------------------------------------------------------------------------- /Compilation-policy/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-compilation-policy)))) 4 | (list (find-package "CLEAVIR-COMPILATION-POLICY"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-compilation-policy)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /Conditions/README.md: -------------------------------------------------------------------------------- 1 | `cleavir-conditions` is a small system basically defining two hierarchies of conditions: `program-condition` and `compiler-note`. 2 | 3 | # Program conditions 4 | 5 | Program conditions (`program-error`, `program-warning`, etc.) are conditions indicating a problem in the source code passed in for compilation or other processing. For example, forms like `(cons 1 2 3)` or `(progn . 4)` could induce program conditions. 6 | 7 | There are two basic reasons for these conditions. One is so that users of Cleavir can distinguish problems found by Cleavir in its input from problems Cleavir itself runs into. A program condition does not indicate any kind of problem in Cleavir but rather a problem with its input, whereas some other condition might be a bug in Cleavir. Secondly, all program conditions have an associated source location indicating the part of the input program with the issue. This source location can be read with the `origin` function. Clients defining their own program conditions may wish to define methods on this function. 8 | 9 | # Compiler notes 10 | 11 | Notes (`program-note`) can be used by compilers for conditions not warranting even a style warning. This could include compiler-specific optimization hints, or notes that the compiler will ignore some declaration because it is not smart enough to use it, for example. Essentially, they do not indicate a problem with the code itself per se, but the compiler is not doing its best with it. 12 | -------------------------------------------------------------------------------- /Conditions/cleavir-conditions.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem #:cleavir-conditions 4 | :description "Utilities for conditions signaled by compilers." 5 | :author "Bike " 6 | :maintainer "Bike " 7 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-conditions/" 8 | :version "1.0.0" 9 | :license "BSD" 10 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 11 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 12 | :depends-on (:acclimation) 13 | :components 14 | ((:file "packages") 15 | (:file "program-condition" :depends-on ("packages")) 16 | (:file "origin" :depends-on ("packages")) 17 | (:file "note" :depends-on ("program-condition" "packages")))) 18 | -------------------------------------------------------------------------------- /Conditions/note.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-conditions) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Condition type PROGRAM-NOTE 6 | ;;; 7 | ;;; PROGRAM-NOTE can be used for information that a programmer may wish to be 8 | ;;; informed of but which does not warrant even a STYLE-WARNING. This could 9 | ;;; include optimization hints or notes that the compiler will ignore some 10 | ;;; declaration because it is not smart enough to use it, for example. 11 | ;;; Essentially, there is no problem with the code itself per se, but the 12 | ;;; compiler is not doing its best with it. 13 | 14 | (define-condition program-note (program-condition) ()) 15 | 16 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | ;;; 18 | ;;; Function NOTE 19 | ;;; 20 | ;;; Signal a compiler note. The MUFFLE-NOTE restart can be used to prevent any 21 | ;;; reporting from being done. Otherwise, the note will be displayed on 22 | ;;; *error-output*. 23 | ;;; We have no simple-program-note class for reasons of internal hygeine, 24 | ;;; so unlike cl:error and cl:warn, we only accept condition type specifiers 25 | ;;; as DATUM. 26 | 27 | (defun note (datum &rest arguments) 28 | (let ((note (apply #'make-condition datum arguments))) 29 | (restart-case (signal note) 30 | (muffle-note () 31 | :report "Silence note." 32 | (return-from note nil))) 33 | ;;; TODO: Maybe display origin or provide a way for clients to do so 34 | ;;; in some customizable fashion? 35 | (format *error-output* "~&;;; Note: ~a~%" note))) 36 | 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | ;;; 39 | ;;; Function MUFFLE-NOTE 40 | ;;; 41 | ;;; Invoke the MUFFLE-NOTE restart. If there is no active MUFFLE-NOTE restart, 42 | ;;; signals a CONTROL-ERROR. In either case, does not return. 43 | 44 | (defun muffle-note (&optional condition) 45 | (invoke-restart (find-restart 'muffle-note condition))) 46 | -------------------------------------------------------------------------------- /Conditions/origin.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-conditions) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Generic function ORIGIN 6 | ;;; 7 | ;;; This returns the source position a condition originated from. 8 | (defgeneric origin (condition)) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;;; 12 | ;;; Condition type ORIGIN 13 | ;;; 14 | ;;; ORIGIN is a convenience mixin for condition types that directly store their 15 | ;;; origin in a slot. 16 | (define-condition origin (acclimation:condition) 17 | ((%origin :initarg :origin :reader origin))) 18 | -------------------------------------------------------------------------------- /Conditions/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-conditions 4 | (:use #:common-lisp) 5 | (:shadow #:program-error) 6 | (:export #:program-condition 7 | #:program-error #:program-warning #:program-style-warning) 8 | (:export #:origin) 9 | (:export #:program-note #:note #:muffle-note)) 10 | -------------------------------------------------------------------------------- /Conditions/program-condition.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-conditions) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Condition type PROGRAM-CONDITION 6 | ;;; 7 | ;;; This is the abstract class of all conditions Cleavir signals to note 8 | ;;; problems and anything else about a program it has been input. 9 | ;;; For example, a warning about an unused variable is a program condition, 10 | ;;; but an internal inconsistency in Cleavir's code is not. 11 | ;;; The idea is that program conditions have certain regular features (namely, 12 | ;;; source locations). Furthermore, clients may want to tag non-program 13 | ;;; conditions as arising from bugs in client code or Cleavir itself. 14 | 15 | (define-condition program-condition (acclimation:condition) ()) 16 | 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | ;;; 19 | ;;; Condition type PROGRAM-ERROR 20 | ;;; 21 | ;;; Abstract class for program errors. In the context of Cleavir, a "program 22 | ;;; error" is a problem with the code that prevents further compilation without 23 | ;;; further intervention. This is the definition of compiler-signaled ERRORs 24 | ;;; laid out in CLHS 3.2.5 "Exceptional Situations in the Compiler". 25 | ;;; Note that Cleavir signals errors where many clients would wish for a warning 26 | ;;; or less; for example, CST-to-AST signals an error for unbound variables, but 27 | ;;; most Lisp implementations implicitly treat unbound variables as special 28 | ;;; variables and signal only a warning. If a client wishes to do this, it must 29 | ;;; affirmatively handle Cleavir's condition and signal a warning instead. 30 | 31 | (define-condition program-error (program-condition cl:program-error) ()) 32 | 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | ;;; 35 | ;;; Condition type PROGRAM-WARNING 36 | ;;; 37 | ;;; Abstract class for program warnings. Here, program warnings indicate that 38 | ;;; code can be compiled without outside intervention, but it will have 39 | ;;; undefined consequences, or an undesirable error will be signaled at runtime. 40 | ;;; Again, this is as laid out in CLHS 3.2.5. Keep in mind that the compiler 41 | ;;; signaling a warning results in compilation failure with COMPILE[-FILE]. 42 | 43 | (define-condition program-warning (program-condition warning) ()) 44 | 45 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 46 | ;;; 47 | ;;; Condition type PROGRAM-STYLE-WARNING 48 | ;;; 49 | ;;; Abstract class for program style warnings. As usual, a style warning is a 50 | ;;; warning about a program that has well-defined consequences, but may be 51 | ;;; suboptimal or "ugly" in some way, and possibly indicate other problems. 52 | ;;; CLHS 3.2.5 gives the example of leaving an un-IGNOREd variable unused. 53 | 54 | (define-condition program-style-warning (program-condition style-warning) ()) 55 | -------------------------------------------------------------------------------- /Conditions/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-conditions)))) 4 | (list (find-package "CLEAVIR-CONDITIONS"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-conditions)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /Ctype/README.md: -------------------------------------------------------------------------------- 1 | The `cleavir-ctype` system defines an interface for Cleavir to interact with a client's type system. This is necessary because the standard hook for working with types, `cl:subtypep`, cannot be used to efficiently implement the kind of type operations Cleavir needs. Clients may have more efficient representations than type specifiers, and may have operations for manipulating these representations more generally and efficiently. 2 | 3 | This is not an implementation of the type system in itself. Without client customization, `cl:subtypep` will be used. 4 | 5 | `cleavir-ctype` consists of three rough subcomponents: type operations, type construction, and type readers. Type operations are operations on types, such as `subtypep` and `conjoin`. Type construction functions create some client representation of a type, and type readers get information from these client representations. Throughout Cleavir, various operators refer to "ctypes" rather than "types" to mean these representations. 6 | 7 | # Type operations 8 | 9 | Besides `subtypep`, there are `conjoin`, `disjoin`, `negate`, `subtract`, and `disjointp`. These essentially continue the CL standard's treatment of types as sets. `disjointp`, which determines if two ctypes contain any common elements, is especially important for optimization. 10 | 11 | # Type construction 12 | 13 | The system contains generic functions for the various kinds of types defined by the standard - array types, real ranges, etc. These functions generally take an object representing the client as a parameter, so that methods may be defined, and then take other ctypes as more parameters. 14 | 15 | # Handling of `values` 16 | 17 | The `cl:values` types present some issue. The standard allows single-value types (that is, most of them) in essentially any place that values types are possible. Ctype is more explicit about the distinction. There are `values-` versions of the type operations; these versions take values ctypes as arguments, and the non-`values-` versions do not. `coerce-to-values`, `single-value`, `primary`, and `nth-value` can be used to convert to and from values ctypes. 18 | -------------------------------------------------------------------------------- /Ctype/cleavir-ctype.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-ctype 4 | :description "Interface to client type systems." 5 | :author ("Bike " 6 | "Charles Zhang") 7 | :maintainer "Bike " 8 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-ctype/" 9 | :version "1.0.0" 10 | :license "BSD" 11 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 12 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 13 | :depends-on (:cleavir-io 14 | :cleavir-attributes 15 | :cleavir-meter) 16 | 17 | :depends-on () 18 | :components 19 | ((:file "packages") 20 | (:file "generic-functions" :depends-on ("packages")) 21 | (:file "other-functions" :depends-on ("packages")) 22 | (:file "default" :depends-on ("generic-functions" 23 | "packages")))) 24 | -------------------------------------------------------------------------------- /Ctype/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cleavir-ctype 2 | (:use #:common-lisp) 3 | (:shadow #:subtypep 4 | #:upgraded-array-element-type 5 | #:upgraded-complex-part-type 6 | #:class #:cons #:array #:string 7 | #:consp #:arrayp #:array-element-type #:array-dimensions 8 | #:character #:base-char #:standard-char 9 | #:complex #:fixnum #:member #:complexp 10 | #:satisfies #:keyword #:function #:compiled-function 11 | #:values #:nth-value #:funcall #:apply #:functionp) 12 | (:export #:subtypep 13 | #:upgraded-array-element-type 14 | #:upgraded-complex-part-type) 15 | (:export #:conjoin/2 #:disjoin/2 #:negate #:subtract 16 | #:top #:bottom #:top-p #:bottom-p 17 | #:values-top #:values-bottom #:values-top-p #:values-bottom-p 18 | #:conjoin #:disjoin #:disjointp) 19 | (:export #:values-conjoin/2 #:values-disjoin/2 #:values-disjointp 20 | #:values-conjoin #:values-disjoin 21 | #:values-append/2 #:values-append) 22 | (:export #:wdisjoin/2 #:wdisjoin #:values-wdisjoin/2 #:values-wdisjoin) 23 | (:export #:conjunctionp #:disjunctionp 24 | #:conjunction-ctypes #:disjunction-ctypes 25 | #:negationp #:negation-ctype 26 | #:class #:cons #:array #:string 27 | #:consp #:cons-car #:cons-cdr 28 | #:arrayp #:array-simplicity #:array-element-type #:array-dimensions 29 | #:character #:base-char #:standard-char 30 | #:complex #:range #:fixnum #:complexp #:complex-part-type 31 | #:rangep #:range-kind #:range-high #:range-low 32 | #:member #:member-p #:member-members 33 | #:satisfies #:satisfiesp #:satisfies-fname #:keyword 34 | #:function #:compiled-function #:values #:coerce-to-values) 35 | (:export #:values-required #:values-optional #:values-rest 36 | #:nth-value #:primary #:single-value) 37 | (:export #:functionp #:function-required #:function-optional #:function-rest 38 | #:function-keysp #:function-keys #:function-allow-other-keys-p 39 | #:function-values) 40 | (:export #:function-top) 41 | (:export #:values-subtypep) 42 | (:export #:apply #:funcall)) 43 | -------------------------------------------------------------------------------- /Ctype/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-ctype)))) 4 | (list (find-package "CLEAVIR-CTYPE"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-ctype)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /Def-use-chains/cleavir-def-use-chains-test.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-def-use-chains-test 4 | :depends-on (:cleavir-def-use-chains 5 | :cleavir-graph-test-utilities) 6 | :serial t 7 | :components 8 | ((:file "test-packages") 9 | (:file "test-def-use-chains"))) 10 | -------------------------------------------------------------------------------- /Def-use-chains/cleavir-def-use-chains.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-def-use-chains 4 | :depends-on (:cleavir-reaching-definitions) 5 | :serial t 6 | :components 7 | ((:file "packages") 8 | (:file "def-use-chains"))) 9 | -------------------------------------------------------------------------------- /Def-use-chains/def-use-chains.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-def-use-chains) 2 | 3 | ;;; We return a list of def-use chains. Each def-use chain is 4 | ;;; represented by a list whose CAR is the DEFINITION (i.e, a CONS of 5 | ;;; a NODE and a VARIABLE), and whose CDR is a list of nodes where the 6 | ;;; definition is used. 7 | (defun def-use-chains (graph) 8 | (let ((reaching-definitions 9 | (cleavir-reaching-definitions:reaching-definitions graph)) 10 | (def-use-chains (make-hash-table :test #'eq))) 11 | (cleavir-graph:with-graph (graph) 12 | (cleavir-graph:do-nodes (node) 13 | (loop for reaching in (cleavir-reaching-definitions:reaching 14 | node reaching-definitions) 15 | do (when (cleavir-graph:do-inputs (input nil) 16 | (when (eq input (cdr reaching)) (return t))) 17 | (push node (gethash reaching def-use-chains)))))) 18 | (let ((result '())) 19 | (maphash (lambda (definition nodes) 20 | (push (cons definition nodes) result)) 21 | def-use-chains) 22 | result))) 23 | -------------------------------------------------------------------------------- /Def-use-chains/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-def-use-chains 4 | (:use #:common-lisp) 5 | (:export 6 | #:def-use-chains 7 | )) 8 | -------------------------------------------------------------------------------- /Def-use-chains/test-def-use-chains.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-def-use-chains-test) 2 | 3 | (defun nodes-used-by-definition (graph node var) 4 | (let ((result '())) 5 | (cleavir-graph:with-graph (graph) 6 | (labels ((inputp (node var) 7 | (cleavir-graph:do-inputs (in node nil) 8 | (when (eq in var) (return t)))) 9 | (outputp (node var) 10 | (cleavir-graph:do-outputs (out node nil) 11 | (when (eq out var) (return t)))) 12 | (traverse (node path) 13 | (unless (or (member node path :test #'eq) 14 | (member node result :test #'eq)) 15 | (when (inputp node var) (push node result)) 16 | (unless (outputp node var) 17 | (cleavir-graph:do-successors (succ node) 18 | (traverse succ (cons node path))))))) 19 | (cleavir-graph:do-successors (succ node) 20 | (traverse succ '())))) 21 | result)) 22 | 23 | (defun test-def-use-chains-one-graph (graph) 24 | (let ((def-use-chains (cleavir-def-use-chains:def-use-chains graph))) 25 | ;; First check that each def-use chain is correct, i.e., that the 26 | ;; use nodes mentioned in it are precisely the nodes that can be 27 | ;; reached by the definition. 28 | (loop for (def . uses) in def-use-chains 29 | do (let* ((nodes (nodes-used-by-definition 30 | graph (car def) (cdr def)))) 31 | (assert (and (subsetp nodes uses :test #'eq) 32 | (subsetp uses nodes :test #'eq))))) 33 | ;; Next check that for every definition, there is a def-use-chain 34 | ;; that containes precisely the nodes that can be reached by that 35 | ;; definition. 36 | (cleavir-graph:with-graph (graph) 37 | (cleavir-graph:do-nodes (node) 38 | (cleavir-graph:do-outputs (var node) 39 | (let ((nodes (nodes-used-by-definition graph node var)) 40 | (uses (assoc (cons node var) def-use-chains 41 | :test #'equal))) 42 | (assert (and (subsetp nodes uses :test #'eq) 43 | (subsetp uses nodes :test #'eq))))))))) 44 | 45 | (defun test-def-use-chains (&optional (n 10000)) 46 | (loop repeat n 47 | do (test-def-use-chains-one-graph 48 | (cleavir-graph-test-utilities:random-flow-chart)))) 49 | -------------------------------------------------------------------------------- /Def-use-chains/test-packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-def-use-chains-test 4 | (:use #:common-lisp) 5 | (:export 6 | #:test-def-use-chains)) 7 | -------------------------------------------------------------------------------- /Documentation-generation/README.md: -------------------------------------------------------------------------------- 1 | This is a sham system that facilitates generating Cleavir's documentation. It is an extension to [Staple](https://github.com/Shinmera/staple); if you are looking for a general documentation generation system for use with your own code, Staple is what Cleavir is using. 2 | 3 | # Generating the documentation 4 | 5 | Ensure the `staple-markdown` system is loaded. Then simply 6 | 7 | ```lisp 8 | (staple:generate :cleavir-documentation-generation :if-exists :supersede) 9 | ``` 10 | 11 | ## Developer details 12 | 13 | This system is empty - as you can see from the ASDF system definition, it includes no files and has no dependencies. Loading it won't do you any good. The documentation generation is set up in `staple.ext.lisp`, which Staple will automatically load in the course of the above `generate` call. 14 | 15 | `staple.ext.lisp` defines a moderately extensive extension to Staple in order to improve its handling of Cleavir, which is a very complex set of systems. Unlike usual Staple, this documentation generator produces a hierarchy of `staple:project` instances rather than just one. 16 | 17 | Cleavir systems may put in further extensions particular to those systems with their own `staple.ext.lisp` files. It is recommended that these be written in the `cleavir-documentation-generation` package defined here. The extension has been written such that the usual Staple generic functions are still used, so you can define methods as needed, although you probably shouldn't further customize `staple:find-project`. Systems should make sure their pages are instances of `cleavir-page` in order for source code links to work correctly. 18 | 19 | # Generating the CSS 20 | 21 | The CSS file used for the documentation is generated from the [LASS](https://github.com/Shinmera/LASS) file. To recompile, 22 | 23 | ```lisp 24 | (lass:generate (asdf:system-relative-pathname :cleavir-documentation-generation "top.lass")) 25 | ``` 26 | 27 | # Copyright 28 | 29 | `top.ctml`, `main.ctml`, and `top.lass` are modifications of Staple's `default/default.ctml` and `default/default.lass`. The original files were authored by Nicolas Hafner (a.k.a. [Shinmera](https://github.com/Shinmera)), and the modified files are used here under the zlib license. Here is the original notice: 30 | 31 | ``` 32 | Copyright (c) 2014 Nicolas Hafner 33 | 34 | This software is provided 'as-is', without any express or implied 35 | warranty. In no event will the authors be held liable for any damages 36 | arising from the use of this software. 37 | 38 | Permission is granted to anyone to use this software for any purpose, 39 | including commercial applications, and to alter it and redistribute it 40 | freely, subject to the following restrictions: 41 | 42 | 1. The origin of this software must not be misrepresented; you must not 43 | claim that you wrote the original software. If you use this software 44 | in a product, an acknowledgment in the product documentation would be 45 | appreciated but is not required. 46 | 2. Altered source versions must be plainly marked as such, and must not be 47 | misrepresented as being the original software. 48 | 3. This notice may not be removed or altered from any source distribution. 49 | ``` 50 | -------------------------------------------------------------------------------- /Documentation-generation/cleavir-documentation-generation.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :cleavir-documentation-generation 2 | :description "Dummy system used for generating Cleavir's documentation." 3 | ;; I (Bike) am so far the only author, but Staple uses the authors on the front page. 4 | ;; That could be fixed up, but in the meantime, as a bit of a hack, anybody who's 5 | ;; done substantial work on Cleavir is included here. 6 | :author ("Robert Strandh " 7 | "Bike " 8 | "Charles Zhang" 9 | "Jan Moringen " 10 | "Marco Heisig ") 11 | :maintainer "Bike " 12 | :homepage "https://s-expressionists.github.io/Cleavir/" 13 | ;; similar to above hack, this is used as the overall version of Cleavir. 14 | :version (:read-file-form "../version.sexp") 15 | :license "BSD") 16 | -------------------------------------------------------------------------------- /Documentation-generation/top.css: -------------------------------------------------------------------------------- 1 | html body{margin:0 auto 0 auto;padding:20px;max-width:1024px;font-family:sans-serif;font-size:14pt;overflow-y:scroll;}html body a{text-decoration:none;}html body a[href]{color:#0055AA;}html body a[href]:hover{color:#0088EE;}html body pre{background:#FAFAFA;border:1px solid #DDDDDD;padding:0.75em;overflow-x:auto;}html body pre >code a[href]{color:#223388;}article.project h1{font-size:1.7em;}article.project h1,article.project h2,article.project h3,article.project h4,article.project h5,article.project h6{margin:0.2em 0 0.1em 0;text-indent:1em;}article.project >header{text-align:center;}article.project >header img.logo{display:block;margin:auto;max-height:170px;}article.project >header h1{display:inline-block;text-indent:0;font-size:2.5em;}article.project >header .version{vertical-align:bottom;}article.project >header .languages{margin-top:-0.5em;text-transform:capitalize;}article.project >header .description{margin:0;}article.project >header .pages{margin-top:0.5em;font-size:1.2em;text-transform:capitalize;}article.project >header .pages a{display:inline-block;padding:0 0.2em;}article.project >section{margin:1em 0 1em 0;}article.project #subsystems >ul{list-style:none;margin:0;padding:0;}article.project .row label{display:inline-block;min-width:8em;}article.project #system .row{display:flex;}article.project #system #dependencies{display:inline;margin:0;padding:0;}article.project #system #dependencies li{display:inline;padding:0 0.2em;}article.project #system #author label{vertical-align:top;}article.project #system #author ul{display:inline-block;margin:0;padding:0;list-style:none;}article.subsystem{margin:1em 0 0 0;}article.subsystem >header h1,article.subsystem >header h2,article.subsystem >header h3,article.subsystem >header h4,article.subsystem >header h5,article.subsystem >header h6{text-indent:0;display:inline-block;}article.subsystem >header ul{display:inline-block;list-style:none;margin:0;padding:0;}article.subsystem >header ul li{display:inline-block;padding:0 0.2em 0 0;}article.subsystem >header .visibility{display:none;}article.subsystem >header .visibility,article.subsystem >header .type{text-transform:lowercase;}article.subsystem >header .source-link{visibility:hidden;float:right;}.subsystem li>mark{background:none;border-left:0.3em solid #0088EE;padding-left:0.3em;display:block;} -------------------------------------------------------------------------------- /Documentation-generation/top.lass: -------------------------------------------------------------------------------- 1 | (html 2 | (body 3 | :margin 0 auto 0 auto 4 | :padding 20px 5 | :max-width 1024px 6 | :font-family sans-serif 7 | :font-size 14pt 8 | :overflow-y scroll 9 | (a 10 | :text-decoration none) 11 | (a[href] 12 | :color (hex 0055AA)) 13 | ((:and a[href] :hover) 14 | :color (hex 0088EE)) 15 | (pre 16 | :background (hex FAFAFA) 17 | :border 1px solid (hex DDDDDD) 18 | :padding 0.75em 19 | :overflow-x auto 20 | (>code 21 | (a[href] 22 | :color (hex 223388)))))) 23 | 24 | (article.project 25 | (h1 26 | :font-size 1.7em) 27 | ((:or h1 h2 h3 h4 h5 h6) 28 | :margin 0.2em 0 0.1em 0 29 | :text-indent 1em) 30 | (>header 31 | :text-align center 32 | (img.logo 33 | :display block 34 | :margin auto 35 | :max-height 170px) 36 | (h1 37 | :display inline-block 38 | :text-indent 0 39 | :font-size 2.5em) 40 | (.version 41 | :vertical-align bottom) 42 | (.languages 43 | :margin-top -0.5em 44 | :text-transform capitalize) 45 | (.description 46 | :margin 0) 47 | (.pages 48 | :margin-top 0.5em 49 | :font-size 1.2em 50 | :text-transform capitalize 51 | (a :display inline-block 52 | :padding 0 0.2em))) 53 | (>section 54 | :margin 1em 0 1em 0) 55 | ("#subsystems" 56 | (>ul 57 | :list-style none 58 | :margin 0 :padding 0)) 59 | (.row 60 | (label 61 | :display inline-block 62 | :min-width 8em)) 63 | ("#system" 64 | (.row 65 | :display flex) 66 | ("#dependencies" 67 | :display inline 68 | :margin 0 :padding 0 69 | (li :display inline 70 | :padding 0 0.2em)) 71 | ("#author" 72 | (label :vertical-align top) 73 | (ul :display inline-block 74 | :margin 0 :padding 0 75 | :list-style none)))) 76 | 77 | (article.subsystem 78 | :margin 1em 0 0 0 79 | (>header 80 | ((:or h1 h2 h3 h4 h5 h6) 81 | :text-indent 0 82 | :display inline-block) 83 | (ul 84 | :display inline-block 85 | :list-style none 86 | :margin 0 :padding 0 87 | (li :display inline-block 88 | :padding 0 0.2em 0 0)) 89 | (.visibility 90 | :display none) 91 | ((:or .visibility .type) 92 | :text-transform lowercase) 93 | (.source-link 94 | :visibility hidden 95 | :float right))) 96 | 97 | (.subsystem 98 | (li>mark 99 | :background none 100 | :border-left 0.3em solid (hex 0088EE) 101 | :padding-left 0.3em 102 | :display block)) 103 | -------------------------------------------------------------------------------- /Dominance/cleavir-dominance-test.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-dominance-test 4 | :depends-on (:cleavir-graph :cleavir-graph-test-utilities 5 | :cleavir-dominance) 6 | :components 7 | ((:file "test-packages" :depends-on ()) 8 | (:file "test-dominance" :depends-on ("test-packages")))) 9 | -------------------------------------------------------------------------------- /Dominance/cleavir-dominance.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-dominance 4 | :depends-on (:cleavir-graph :cleavir-meter) 5 | :serial t 6 | :components 7 | ((:file "packages") 8 | (:file "dominance"))) 9 | -------------------------------------------------------------------------------- /Dominance/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-dominance 4 | (:use #:common-lisp) 5 | (:export 6 | #:dominance-tree 7 | #:children 8 | #:dominators 9 | #:strict-dominators 10 | #:immediate-dominator 11 | #:dominance-frontiers 12 | #:dominance-frontier 13 | #:dominance-frontier-set 14 | #:dominance-frontier+ 15 | )) 16 | -------------------------------------------------------------------------------- /Dominance/test-packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-dominance-test 4 | (:use #:common-lisp) 5 | (:export 6 | #:test 7 | )) 8 | -------------------------------------------------------------------------------- /Environment/README.md: -------------------------------------------------------------------------------- 1 | The `cleavir-env` system defines an interface Cleavir can use to query information from client environments. It also defines lexical environment objects used internally when processing code (e.g. for `cleavir-cst-to-ast`). 2 | 3 | This system is slated to be phased out in favor of [Trucler](https://github.com/s-expressionists/Trucler/). The only unresolved sticking point is that Cleavir sometimes wants to stick its own information into lexical environments, and this is not possible for unprepared clients. 4 | 5 | # Minimal definitions by clients 6 | 7 | Briefly, here are the generic functions that must be specialized in order for `cleavir-cst-to-ast` to work: 8 | 9 | * `variable-info`: Returns information about variables. 10 | * `function-info`: Retrieves information about operators (functions, macros, special operators). 11 | * `optimize-info`: Retrives information about current optimization settings, as well as current policy (see the cleavir-compilation-policy system). 12 | * `declaration`: Retrieves the list of valid nonstandard declarations. 13 | * `type-expand`: Analogously to `cl:macroexpand`, expands macro (`deftype`-defined) type specifiers. This is required for CST-to-AST to do any type specifier parsing, which it may need to do even if the program contains no type declarations. Type specifier parsing can be further customized via the other generic functions in cleavir-environment, as well as the cleavir-ctype system, but this is not necessary. 14 | * `eval`: Evaluates a form. This is used in conversion of `cl:macrolet` to produce the local macroexpander. 15 | * `cst-eval`: Evaluates a CST of a form. This is used to execute compile-time side effects. 16 | 17 | An example set of method definitions can be seen in the `cleavir-example` system. 18 | -------------------------------------------------------------------------------- /Environment/augmentation-functions.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-environment) 2 | 3 | (defgeneric add-lexical-variable (environment symbol &optional identity)) 4 | 5 | (defgeneric add-special-variable (environment symbol)) 6 | 7 | (defgeneric add-local-symbol-macro (environment symbol expansion)) 8 | 9 | (defgeneric add-local-function (environment function-name &optional identity)) 10 | 11 | (defgeneric add-local-macro (environment symbol expander)) 12 | 13 | (defgeneric add-block (environment symbol &optional identity)) 14 | 15 | (defgeneric add-tag (environment symbol &optional identity)) 16 | 17 | (defgeneric add-variable-type (environment symbol type)) 18 | 19 | (defgeneric add-function-type (environment function-name type)) 20 | 21 | (defgeneric add-variable-ignore (environment symbol ignore)) 22 | 23 | (defgeneric add-function-ignore (environment function-name ignore)) 24 | 25 | (defgeneric add-variable-dynamic-extent (environment symbol)) 26 | 27 | (defgeneric add-function-dynamic-extent (environment function-name)) 28 | 29 | (defgeneric add-optimize (environment optimize policy)) 30 | 31 | (defgeneric add-inline (environment function-name inline)) 32 | 33 | (defgeneric add-inline-expansion (environment function-name expansion)) 34 | -------------------------------------------------------------------------------- /Environment/cleavir-environment.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-environment 4 | :description "Interface for managing lexical environments." 5 | :author ("Robert Strandh " "Bike ") 6 | :maintainer "Bike " 7 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-environment/" 8 | :version "1.0.0" 9 | :license "BSD" 10 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 11 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 12 | :depends-on (:acclimation :cleavir-ctype :cleavir-attributes) 13 | :serial t 14 | :components 15 | ((:file "packages") 16 | (:file "query") 17 | (:file "augmentation-functions") 18 | (:file "default-augmentation-classes") 19 | (:file "compile-time") 20 | (:file "optimize-qualities") 21 | (:file "declarations") 22 | (:file "type-information") 23 | (:file "default-info-methods") 24 | (:file "eval"))) 25 | -------------------------------------------------------------------------------- /Environment/declarations.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-environment) 2 | 3 | ;;; This generic function takes an environment and returns a list of 4 | ;;; declaration identifers declared by the implementation or user 5 | ;;; (by (DECLAIM (DECLARATION ...))) 6 | 7 | (defgeneric declarations (environment)) 8 | 9 | ;;; An implementation should track declaim declaration, so we don't 10 | ;;; define a default empty method. 11 | 12 | ;;; But if it's called on a Cleavir environment, we should go up. 13 | (defmethod declarations ((environment entry)) 14 | (declarations (next environment))) 15 | -------------------------------------------------------------------------------- /Environment/optimize-qualities.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-environment) 2 | 3 | ;;; This generic function takes an environment object and returns a 4 | ;;; list of allowed optimize qualities. An optimize quality is 5 | ;;; represented as a list (NAME TYPE DEFAULT-VALUE) where NAME is the 6 | ;;; name of the optimize quality, TYPE is the type of the values of 7 | ;;; this optimize quality, and DEFAULT-VALUE is the default value of 8 | ;;; this optimize quality, i.e. the value that is assumed when a 9 | ;;; declaration of the form (OPTIMIZE NAME) is encountered. 10 | (defgeneric optimize-qualities (environment)) 11 | 12 | ;;; This method is called on the global environment when no 13 | ;;; implementation-specific method has been defined. It returns the 14 | ;;; optimize qualities defined in the HyperSpec. 15 | (defmethod optimize-qualities (environment) 16 | (declare (cl:ignore environment)) 17 | '((speed (integer 0 3) 3) 18 | (debug (integer 0 3) 3) 19 | (space (integer 0 3) 3) 20 | (compilation-speed (integer 0 3) 3) 21 | (safety (integer 0 3) 3))) 22 | 23 | ;;; This method is called on an environment object other than the 24 | ;;; global environment. It simply calls OPTIMIZE-QUALITIES again with 25 | ;;; the parent object. 26 | (defmethod optimize-qualities ((environment entry)) 27 | (optimize-qualities (next environment))) 28 | -------------------------------------------------------------------------------- /Environment/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-environment 4 | (:nicknames #:cleavir-env) 5 | (:use #:common-lisp) 6 | (:local-nicknames (#:ctype #:cleavir-ctype)) 7 | (:shadow #:identity 8 | #:type 9 | #:ignore 10 | #:dynamic-extent 11 | #:compiler-macro 12 | #:eval 13 | #:macro-function 14 | #:compiler-macro-function 15 | #:find-class 16 | #:function 17 | #:block 18 | #:inline 19 | #:optimize) 20 | (:export 21 | #:variable-info 22 | #:lexical-variable-info 23 | #:special-variable-info 24 | #:constant-variable-info 25 | #:symbol-macro-info 26 | #:function-info 27 | #:local-function-info 28 | #:global-function-info 29 | #:local-macro-info 30 | #:global-macro-info 31 | #:special-operator-info 32 | #:primitive-operator-info 33 | #:block-info 34 | #:tag-info 35 | #:optimize-info 36 | #:optimize-qualities 37 | #:global-environment 38 | #:name 39 | #:origin 40 | #:identity 41 | #:type 42 | #:ignore 43 | #:ast 44 | #:dynamic-extent 45 | #:attributes 46 | #:value 47 | #:expansion 48 | #:expander 49 | #:compiler-macro 50 | #:type-expand 51 | #:declarations 52 | #:add-lexical-variable 53 | #:add-special-variable 54 | #:add-local-symbol-macro 55 | #:add-local-function 56 | #:add-local-macro 57 | #:add-block 58 | #:add-tag 59 | #:add-variable-type 60 | #:add-function-type 61 | #:add-variable-ignore 62 | #:add-function-ignore 63 | #:add-variable-dynamic-extent 64 | #:add-function-dynamic-extent 65 | #:add-optimize 66 | #:add-inline 67 | #:add-inline-expansion 68 | #:eval 69 | #:cst-eval 70 | #:macro-function 71 | #:compiler-macro-function 72 | #:symbol-macro-expansion 73 | #:find-class 74 | #:lexical-variable 75 | #:special-variable 76 | #:global-p 77 | #:symbol-macro 78 | #:function 79 | #:macro 80 | #:block 81 | #:tag 82 | #:variable-type 83 | #:function-type 84 | #:variable-ignore 85 | #:function-ignore 86 | #:variable-dynamic-extent 87 | #:function-dynamic-extent 88 | #:inline 89 | #:inline-expansion 90 | #:optimize 91 | #:policy 92 | #:environment-policy 93 | #:compile-time 94 | #:parse-type-specifier 95 | #:parse-values-type-specifier 96 | #:parse-expanded-type-specifier 97 | #:parse-compound-type-specifier)) 98 | -------------------------------------------------------------------------------- /Environment/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-environment)))) 4 | (list (find-package "CLEAVIR-ENVIRONMENT"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-environment)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /Example/README.md: -------------------------------------------------------------------------------- 1 | Cleavir is a collection of parts that can be used to make a Lisp compiler. A Lisp compiler is closely linked to the Lisp runtime, both in that it must target the runtime, and it must sometimes actually use it to evaluate Lisp code. As such, Cleavir cannot operate as an independent system. 2 | 3 | This makes it harder to get started on understanding and using Cleavir. To rectify this problem, this directory defines a small system making a subset of Common Lisp available, and demonstrates how to use Cleavir as a compiler for this system. 4 | 5 | # Getting started 6 | 7 | 1. Load the `cleavir-example` system. Besides Cleavir systems, it depends on the external systems `concrete-syntax-tree` and `acclimation`, both of which should be available from Quicklisp. 8 | 2. Run `(cleavir-example:load-environment)` to set up the compilation environment. 9 | 3. You can now compile a subset of Lisp code to BIR (Cleavir's intermediate representation). Try `(cleavir-example:frontend (cst:cst-from-expression '(lambda (x) x)))`, for example. 10 | 4. This will return a BIR "module". You can display a disassembly of this module with `(cleavir-bir-disassembler:display module)`. 11 | 12 | # Using the visualizer 13 | 14 | This example system can be used with the BIR visualizer (in BIR/Visualizer) as follows: 15 | 16 | 1. Load the `cleavir-example` and `cleavir-bir-visualizer` systems. 17 | 2. Run `(cleavir-example:load-environment)` to set up the compilation environment. 18 | 3. Run `(cleavir.bir.visualizer:run :environment cleavir-example:*environment* :system cleavir-example:*system*)` to start the visualizer. `:new-process t` can additionally be passed in order to run the visualizer in a new thread, freeing up your REPL. 19 | 4. Enter code in the "Lambda Expression" field (or leave the default), use the Safe/Default/Fast buttons and the optimize sliders to run a compilation, and freely inspect the IR in the "Intermediate Representation" tab. 20 | 21 | # Limitations 22 | 23 | The example system only includes a subset of Common Lisp. Most obviously, only a few basic macros like `lambda`, `cond`, and `dolist` are defined (the complete listing is in macros.lisp). The example system must define all of its own macros, because host system macros (i.e. the macros defined by your Lisp implementation) may expand into nonstandard code that the example system does not know how to process. 24 | 25 | Some standard special operators are not implemented by the basic Cleavir system due to requiring some runtime coordination. These are `catch`, `progv`, `throw`, and `unwind-protect`. Similarly, special variable binding is by default implemented as a function call. The example client implements the special operators as macros expanding into function calls. A full client would probably specify dedicated ASTs and IR for representing these operators. 26 | 27 | Cleavir does not include a backend, since a real full backend more or less requires an entire accompanying Lisp implementation, in order for the details of how code is laid out and run, etc., to be defined. Clients of Cleavir can define their own backends. For example, [Clasp](https://github.com/clasp-developers/clasp) translates BIR into LLVM-IR, which is then passed to LLVM to generate machine code. 28 | -------------------------------------------------------------------------------- /Example/cleavir-example.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-example 4 | :description "Example frontend for the Cleavir toolkit." 5 | :author "Bike " 6 | :maintainer "Bike " 7 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-example/" 8 | :version "1.0.0" 9 | :license "BSD" 10 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 11 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 12 | :depends-on (:cleavir-ctype :cleavir-environment :cleavir-compilation-policy 13 | :cleavir-primop 14 | :cleavir-cst-to-ast :cleavir-ast-to-bir 15 | :cleavir-bir-transformations 16 | :cleavir-abstract-interpreter 17 | :concrete-syntax-tree 18 | :ctype :ctype/tfun) 19 | :components 20 | ((:file "packages") 21 | (:file "system" :depends-on ("packages")) 22 | (:file "environment" :depends-on ("system" "packages")) 23 | (:file "environment-interface" :depends-on ("environment" "system" 24 | "packages")) 25 | (:file "fold" :depends-on ("environment-interface" "system" "packages")) 26 | (:file "type" :depends-on ("system" "packages")) 27 | (:file "derive-type" :depends-on ("system" "packages")) 28 | (:file "macros" :depends-on ("packages")) 29 | (:file "load-environment" :depends-on ("macros" "environment" 30 | "packages")) 31 | (:file "compile" :depends-on ("system" "environment" "packages")))) 32 | -------------------------------------------------------------------------------- /Example/compile.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-example) 2 | 3 | (defun cst->ast (cst) 4 | (cst-to-ast:cst-to-ast cst *environment* *system*)) 5 | 6 | (defun ast->bir (ast) 7 | (ast-to-bir:compile-toplevel ast *system*)) 8 | 9 | (defun cst->bir (cst) 10 | (ast->bir (cst->ast cst))) 11 | 12 | (defun abstract-interpret (module) 13 | (let* ((strategy (make-instance 'abstract-interpreter:sequential-slots)) 14 | (system *system*) 15 | (atype (make-instance 'abstract-interpreter:asserted-type 16 | :system system)) 17 | (dtype (make-instance 'abstract-interpreter:derived-type 18 | :system system)) 19 | (attr (make-instance 'abstract-interpreter:attribute)) 20 | (reach (make-instance 'abstract-interpreter:reachability)) 21 | (ra (make-instance 'abstract-interpreter:reachability->data 22 | :input reach :output atype)) 23 | (rd (make-instance 'abstract-interpreter:reachability->data 24 | :input reach :output dtype)) 25 | (rat (make-instance 'abstract-interpreter:reachability->data 26 | :input reach :output attr)) 27 | (tr (make-instance 'abstract-interpreter:type->reachability 28 | :input dtype :output attr)) 29 | (kc (make-instance 'abstract-interpreter:known-call-channel 30 | :output dtype :other attr :flower #'derive-return-type)) 31 | (product (make-instance 'abstract-interpreter:product 32 | :domains (list atype dtype attr reach) 33 | :channels (list ra rd rat tr kc)))) 34 | (abstract-interpreter:interpret-module strategy product module))) 35 | 36 | (defun transform1 (bir phase) 37 | (ecase phase 38 | ((:eliminate-come-froms) 39 | (bir-transformations:module-eliminate-come-froms bir)) 40 | ((:local-calls) 41 | (bir-transformations:find-module-local-calls bir)) 42 | ((:optimize-variables) 43 | (bir-transformations:module-optimize-variables bir)) 44 | ((:meta-evaluate) 45 | (bir-transformations:meta-evaluate-module bir *system*)) 46 | ((:abstract-interpret) 47 | (abstract-interpret bir)) 48 | ((:generate-type-checks) 49 | (bir-transformations:module-generate-type-checks bir *system*)) 50 | ((:extents) 51 | (bir-transformations:determine-function-environments bir) 52 | (bir-transformations:determine-closure-extents bir) 53 | (bir-transformations:determine-variable-extents bir))) 54 | bir) 55 | 56 | (defparameter *phases* 57 | '(:eliminate-come-froms :local-calls :optimize-variables 58 | :meta-evaluate :generate-type-checks :extents)) 59 | 60 | (defun transform (bir &optional (phases *phases*)) 61 | (loop for phase in phases do (transform1 bir phase)) 62 | bir) 63 | 64 | (defun frontend (cst) 65 | "Given a CST, compile it in the example system and return the resulting post-optimization BIR." 66 | (transform (bir:module (cst->bir cst)))) 67 | -------------------------------------------------------------------------------- /Example/derive-type.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-example) 2 | 3 | (defun derive-return-type (identity argstype) 4 | (ctype.ext.tfun:derive-multiple-value-call (ctype.ext.tfun:find-tfun identity nil) 5 | argstype)) 6 | -------------------------------------------------------------------------------- /Example/environment.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-example) 2 | 3 | ;;;; We define here a global environment for Cleavir to refer to. 4 | ;;;; It includes all the functions and classes in the host (i.e. the 5 | ;;;; Lisp implementation you're loading this in). It does _not_ 6 | ;;;; include macros, because those may expand into implementation- 7 | ;;;; dependent code that Cleavir would have to be taught to process. 8 | ;;;; A few macros for this environment are defined in macros.lisp, 9 | ;;;; but not every standard macro. 10 | 11 | (defclass environment () 12 | ((%variables :initform (make-hash-table) :reader variables 13 | :type hash-table) 14 | (%functions :initform (make-hash-table :test #'eq) 15 | :reader functions :type hash-table) 16 | (%classes :initform (make-hash-table) 17 | :reader classes :type hash-table) 18 | (%type-expanders :initform (make-hash-table) 19 | :reader type-expanders :type hash-table) 20 | (%optimize :initform '((safety 1) (debug 1) (speed 1) 21 | (space 1) (compilation-speed 1)) 22 | :accessor optimize* :type list) 23 | (%policy :accessor policy :type list))) 24 | 25 | (defvar *environment* (make-instance 'environment) 26 | "The \"global\" environment used by the example compiler.") 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;;; 30 | ;;; Basic definitions 31 | ;;; 32 | 33 | (defun %defspecial (name env) 34 | (setf (gethash name (variables env)) `(:special t))) 35 | (defun %defconstant (name value env) 36 | (setf (gethash name (variables env)) `(:constant t ,value))) 37 | (defun %defsmacro (name expansion env) 38 | (setf (gethash name (variables env)) `(:macro t ,expansion))) 39 | (defun proclaim-vartype (name type env) 40 | (let ((info (gethash name (variables env)))) 41 | (if info 42 | (setf (second info) `(and ,(second info) ,type)) 43 | nil))) 44 | 45 | (defun %defun (name env) 46 | (setf (gethash name (functions env)) `(:function))) 47 | (defun %defmacro (name macrofun env) 48 | (setf (gethash name (functions env)) `(:macro ,macrofun))) 49 | 50 | (defun %defclass (name class env) 51 | (setf (gethash name (classes env)) class)) 52 | 53 | (defun proclaim-optimize (optimize env) 54 | (setf (optimize* env) 55 | (policy:normalize-optimize (append optimize (optimize* env)) 56 | env) 57 | (policy env) 58 | (policy:compute-policy (optimize* env) env))) 59 | -------------------------------------------------------------------------------- /Example/fold.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-example) 2 | 3 | ;;;; Demonstration of constant folding. 4 | 5 | (defparameter *constant-fold* t) 6 | (defparameter *folds* (make-hash-table :test #'equal)) 7 | 8 | (defmethod bir-transformations:fold-call ((system example) fold call args) 9 | (declare (ignore call)) 10 | ;; *FOLDS* is defined in environment.lisp. 11 | (let ((folder (gethash fold *folds*))) 12 | (if (and *constant-fold* folder) 13 | (multiple-value-call #'values 14 | t 15 | (handler-case (apply folder args) 16 | (serious-condition (c) 17 | (warn "Serious condition interrupted constant folding:~%~a" c) 18 | (return-from bir-transformations:fold-call nil)))) 19 | nil))) 20 | 21 | (macrolet ((deffold (name) 22 | `(setf (gethash ',name *folds*) #',name)) 23 | (deffolds (&rest names) 24 | `(progn ,@(loop for name in names collect `(deffold ,name))))) 25 | ;; Data and control flow 26 | (deffolds functionp eq eql equal equalp identity complement 27 | values values-list) 28 | ;; Arithmetic 29 | (deffolds = /= < > <= >= max min minusp plusp zerop 30 | ;; Note we can fold functions that return multiple values no problem 31 | floor ffloor ceiling fceiling truncate ftruncate round fround 32 | sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh 33 | * + - / 1+ 1- abs evenp oddp exp expt gcd lcm log mod rem signum 34 | sqrt isqrt numberp cis complex complexp conjugate phase realpart imagpart 35 | realp numerator denominator rational rationalize rationalp 36 | ash integer-length integerp parse-integer boole 37 | logand logandc1 logandc2 logeqv logior lognand lognor lognot 38 | logorc1 logorc2 logxor logbitp logcount logtest 39 | ;; byte specifiers may not be externalizable, so we don't fold BYTE. 40 | ;; this is an example of when a client might make a foldability decision. 41 | byte-size byte-position deposit-field dpb ldb ldb-test mask-field 42 | decode-float scale-float float-radix float-sign float-digits 43 | float-precision integer-decode-float float floatp 44 | arithmetic-error-operands arithmetic-error-operation)) 45 | -------------------------------------------------------------------------------- /Example/load-environment.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-example) 2 | 3 | (defun load-environment (&optional (env *environment*)) 4 | "Fill the given example environment full of much of the CL package, taken from the host. 5 | Note that most macros are not taken, since they may not expand into portable code." 6 | (do-external-symbols (s "CL") 7 | (cond ((constantp s) 8 | (%defconstant s (cl:eval s) env)) 9 | (t (multiple-value-bind (expansion expandedp) 10 | (macroexpand-1 s) 11 | (when expandedp 12 | (%defsmacro s expansion env))))) 13 | (cond ((or (and (fboundp s) 14 | (not (macro-function s)) 15 | (not (special-operator-p s))) 16 | (member s *functions*)) 17 | (%defun s env)) 18 | (t (let ((pair (assoc s *macros*))) 19 | (when pair 20 | (%defmacro s (cdr pair) env))))) 21 | (loop for f in *functions* do (%defun f env)) 22 | (cond ((find-class s nil) 23 | (%defclass s (find-class s) env)))) 24 | ;; Force computing a policy 25 | (proclaim-optimize '((safety 1) (debug 1) (speed 1) (space 1) 26 | (compilation-speed 1)) 27 | env) 28 | (values)) 29 | -------------------------------------------------------------------------------- /Example/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cleavir-example 2 | (:use #:cl) 3 | (:local-nicknames (#:abstract-interpreter #:cleavir-abstract-interpreter) 4 | (#:ast-to-bir #:cleavir-ast-to-bir) 5 | (#:attributes #:cleavir-attributes) 6 | (#:bir #:cleavir-bir) 7 | (#:bir-transformations #:cleavir-bir-transformations) 8 | (#:cst-to-ast #:cleavir-cst-to-ast) 9 | (#:c-ctype #:cleavir-ctype) 10 | (#:env #:cleavir-env) 11 | (#:policy #:cleavir-policy) 12 | (#:primop #:cleavir-primop)) 13 | (:export #:*environment* #:*system*) 14 | (:export #:load-environment) 15 | (:export #:frontend)) 16 | -------------------------------------------------------------------------------- /Example/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-example)))) 4 | (list (find-package "CLEAVIR-EXAMPLE"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-example)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /Example/system.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-example) 2 | 3 | ;;;; This file defines the system, EXAMPLE, used for the example. 4 | ;;;; This is just an object used for discrimination, so it is 5 | ;;;; defined trivially. 6 | 7 | (defclass example () ()) 8 | 9 | (defvar *system* (make-instance 'example) 10 | "An object representing the example system, for use specializing Cleavir generic functions.") 11 | -------------------------------------------------------------------------------- /Flow/cleavir-flow.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :cleavir-flow 2 | :depends-on (:cleavir-graph) 3 | :components 4 | ((:file "packages") 5 | (:file "generic-functions" :depends-on ("packages")) 6 | (:file "traversal" :depends-on ("generic-functions" "packages")) 7 | (:file "flow" :depends-on ("generic-functions" "packages")))) 8 | -------------------------------------------------------------------------------- /Flow/generic-functions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-flow) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Generic function FLOW. 6 | ;;; 7 | ;;; Compute the new information at the given graph node, and if necessary, 8 | ;;; mark other nodes for processing. 9 | ;;; In order for the analysis process to halt at a fixed point, nodes must not 10 | ;;; be marked if there is no more information to compute for them. 11 | ;;; Must be defined for each flow class. 12 | ;;; FLOW is not intended to be called by programmers; they may write methods. 13 | ;;; 14 | 15 | (defgeneric flow (flow graph node)) 16 | 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | ;;; 19 | ;;; Generic function MARK. 20 | ;;; 21 | ;;; While performing a dataflow analysis, mark the given node for processing. 22 | ;;; Only needs to be customized if you are writing your own traversal class. 23 | ;;; For convenience, if called with a flow, MARK will use the flow's traversal. 24 | ;;; Programmers should only call MARK during a FLOW method. 25 | ;;; 26 | 27 | (defgeneric mark (traversal node)) 28 | 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | ;;; 31 | ;;; Generic function WORK. 32 | ;;; 33 | ;;; Do the work of traversing, i.e. iterate through the graph until a fixed 34 | ;;; point is reached. 35 | ;;; Only needs to be customized if you are writing your own traversal class. 36 | ;;; WORK is not intended to be called by programmers; they may write methods. 37 | ;;; 38 | 39 | (defgeneric work (traversal graph)) 40 | 41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 | ;;; 43 | ;;; Generic function INITIALIZE. 44 | ;;; 45 | ;;; Make a traversal ready for WORK. This should involve marking nodes to start 46 | ;;; the analysis from. 47 | ;;; The default method marks all nodes, unless the traversal has a :DIRECTION 48 | ;;; of :FORWARD, in which case it only marks the graph root. 49 | ;;; INITIALIZE is not intended to be called by programmers; they may write 50 | ;;; methods. 51 | ;;; 52 | 53 | (defgeneric initialize (traversal graph)) 54 | -------------------------------------------------------------------------------- /Flow/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cleavir-flow 2 | (:use #:cl) 3 | (:export #:flow #:mark #:work #:initialize) 4 | (:export #:traversal #:worklist) 5 | (:export #:define-flow)) 6 | -------------------------------------------------------------------------------- /Flow/traversal.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-flow) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Class TRAVERSAL. 6 | ;;; 7 | ;;; A traversal represents a way of carrying out a dataflow analysis. 8 | ;;; Traversals are independent from flow classes, i.e. any flow class can be 9 | ;;; used with any traversal class. The traversal only defines a way of 10 | ;;; traversing a graph to carry out an analysis. 11 | ;;; 12 | ;;; Custom traversals must inherit from TRAVERSAL, and define methods on the 13 | ;;; MARK and WORK functions, and optionally the INITIALIZE function. 14 | ;;; 15 | 16 | (defclass traversal () ; abstract 17 | ((%flow :accessor %flow) 18 | (%direction :initarg :direction :initform nil :reader direction))) 19 | 20 | ;;; Default implementation: Serially processed stack. 21 | 22 | (defclass worklist (traversal) 23 | ((%list :initform nil :accessor worklist-list))) 24 | 25 | (defmethod mark ((traversal worklist) node) 26 | (pushnew node (worklist-list traversal) :test #'eq)) 27 | 28 | (defmethod work ((traversal worklist) graph) 29 | (loop for work = (pop (worklist-list traversal)) 30 | do (flow (%flow traversal) graph work) 31 | until (null (worklist-list traversal)))) 32 | 33 | (defmethod initialize ((traversal traversal) graph) 34 | (cleavir-graph:with-graph (graph) 35 | (if (eq (direction traversal) :forward) 36 | (mark traversal (cleavir-graph:root)) 37 | (cleavir-graph:do-nodes (node) (mark traversal node))))) 38 | -------------------------------------------------------------------------------- /Graph/Test-utilities/cleavir-graph-test-utilities.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :cleavir-graph-test-utilities 2 | :depends-on (:cleavir-graph) 3 | :components 4 | ((:file "packages" :depends-on ()) 5 | (:file "test-utilities" :depends-on ("packages")))) 6 | -------------------------------------------------------------------------------- /Graph/Test-utilities/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cleavir-graph-test-utilities 2 | (:use #:cl #:cleavir-graph) 3 | (:export #:node #:make-node #:name #:successors 4 | #:random-flow-chart)) 5 | -------------------------------------------------------------------------------- /Graph/cleavir-graph.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :cleavir-graph 2 | :depends-on () 3 | :components 4 | ((:file "package" :depends-on ()) 5 | (:file "graph" :depends-on ("package")) 6 | (:file "defaults" :depends-on ("graph" "package")))) 7 | -------------------------------------------------------------------------------- /Graph/defaults.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-graph) 2 | 3 | (defun depth-first-preorder-thunk (start-node map-successors-fun) 4 | (declare (type node-mapper map-successors-fun)) 5 | (lambda (function) 6 | (declare (type (function (t)) function)) 7 | (let ((table (make-hash-table :test #'eq))) 8 | (labels ((traverse (node) 9 | (unless (gethash node table) 10 | (setf (gethash node table) t) 11 | (funcall function node) 12 | (funcall map-successors-fun #'traverse node)))) 13 | (traverse start-node))) 14 | (values))) 15 | 16 | (defun depth-first-reverse-postorder-thunk (start-node map-successors-fun) 17 | (declare (type node-mapper map-successors-fun)) 18 | (lambda (function) 19 | (declare (type (function (t)) function)) 20 | (let ((table (make-hash-table :test #'eq))) 21 | (labels ((traverse (node) 22 | (unless (gethash node table) 23 | (setf (gethash node table) t) 24 | (funcall map-successors-fun #'traverse node) 25 | (funcall function node)))) 26 | (traverse start-node))) 27 | (values))) 28 | 29 | ;;; Construct a predecessors mapping from a graph that doesn't have it built in 30 | ;;; by exhaustively iterating through with the successor function, filling a 31 | ;;; table of predecessor relationships, to use for future reference. 32 | (defun map-predecessors-thunk (start-node map-successors-fun) 33 | (declare (type node-mapper map-successors-fun)) 34 | (let ((pred-table (make-hash-table :test #'eq)) 35 | (traversal-table (make-hash-table :test #'eq))) 36 | (labels ((predecessors (node) (gethash node pred-table)) 37 | ((setf predecessors) (preds node) 38 | (setf (gethash node pred-table) preds)) 39 | (traverse (node) 40 | (unless (gethash node traversal-table) 41 | (setf (gethash node traversal-table) t) 42 | (funcall map-successors-fun 43 | (lambda (succ) (push node (predecessors succ))) 44 | node) 45 | (funcall map-successors-fun #'traverse node)))) 46 | (traverse start-node)) 47 | (lambda (function node) 48 | (mapc function (gethash node pred-table)) 49 | (values)))) 50 | 51 | (defun size-thunk (start-node map-successors-fun) 52 | (declare (type node-mapper map-successors-fun)) 53 | (lambda () 54 | (let ((table (make-hash-table :test #'eq)) 55 | (size 0)) 56 | (labels ((traverse (node) 57 | (unless (gethash node table) 58 | (setf (gethash node table) t) 59 | (incf size) 60 | (funcall map-successors-fun #'traverse node)))) 61 | (traverse start-node)) 62 | size))) 63 | -------------------------------------------------------------------------------- /Graph/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cleavir-graph 2 | (:use #:cl) 3 | (:export #:with-graph #:graph-functions) 4 | (:export #:root #:size) 5 | (:export #:map-nodes #:map-nodes-depth-first-preorder) 6 | (:export #:do-nodes #:do-nodes-depth-first-preorder 7 | #:depth-first-preorder) 8 | (:export #:map-inputs #:map-outputs #:map-predecessors #:map-successors) 9 | (:export #:do-inputs #:do-outputs #:do-predecessors #:do-successors) 10 | (:export #:depth-first-preorder-thunk #:depth-first-reverse-postorder-thunk 11 | #:map-predecessors-thunk #:size-thunk)) 12 | -------------------------------------------------------------------------------- /Input-output/README.md: -------------------------------------------------------------------------------- 1 | The `cleavir-io` system defines a macro `define-save-info` that can be used to record what information is required to reconstruct a standard object. This save info is used throughout Cleavir to make objects serializable either as text (via `print-model-object`, `read-model-object`) or by `compile-file` with `make-load-form`. Reader macro syntax is used, so that for example `[foo :bar baz]` can be used as the textual representation of an object of class `foo` with one slot value. 2 | -------------------------------------------------------------------------------- /Input-output/cleavir-io.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-io 4 | :description "Utilities for textual I/O of Lisp objects." 5 | :author "Robert Strandh " 6 | :maintainer "Bike " 7 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-io/" 8 | :version "1.0.0" 9 | :license "BSD" 10 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 11 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 12 | :serial t 13 | :components 14 | ((:file "packages") 15 | (:file "io"))) 16 | -------------------------------------------------------------------------------- /Input-output/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-io 4 | (:use #:common-lisp) 5 | (:export 6 | #:*io-readtable* 7 | #:save-info 8 | #:define-save-info 9 | #:read-model-object 10 | #:read-model 11 | #:write-model)) 12 | 13 | 14 | -------------------------------------------------------------------------------- /Input-output/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-io)))) 4 | (list (find-package "CLEAVIR-IO"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-io)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010 - 2016 Robert Strandh (robert.strandh@gmail.com) 2 | Copyright (c) 2016 - 2022 Cleavir Contributors 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 11 | 12 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Liveness/cleavir-liveness.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-liveness 4 | :depends-on (:cleavir-flow :cleavir-graph :cleavir-set) 5 | :components 6 | ((:file "packages") 7 | (:file "liveness" :depends-on ("packages")))) 8 | -------------------------------------------------------------------------------- /Liveness/liveness.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-liveness) 2 | 3 | (cleavir-flow:define-flow liveness () 4 | ((%live-before :accessor %live-before :reader live-before 5 | :initform (cleavir-set:empty-set)) 6 | (%live-after :accessor %live-after :reader live-after 7 | :initform (cleavir-set:empty-set)))) 8 | 9 | (defmethod cleavir-flow:flow ((flow liveness) graph node) 10 | (cleavir-graph:with-graph (graph) 11 | (let ((live-before (%live-before node flow))) 12 | (unless (cleavir-graph:do-inputs (input node t) ; every 13 | (unless (cleavir-set:presentp input live-before) (return nil))) 14 | (cleavir-graph:do-inputs (input node) 15 | (cleavir-set:nadjoinf (%live-before node flow) input)) 16 | (cleavir-graph:do-predecessors (p node) 17 | (cleavir-set:nunionf (%live-after p flow) live-before) 18 | ;; To the predecessor's live-before, add our live-before, 19 | ;; except for any outputs of the predecessor. 20 | ;; basically union with subtraction, but we avoid consing. 21 | (cleavir-set:doset (elem live-before) 22 | (unless (cleavir-graph:do-outputs (output p nil) ; some 23 | (when (eq elem output) (return t))) 24 | (cleavir-set:nadjoinf (%live-before p flow) elem))) 25 | ;; Mark that predecessor for processing 26 | (cleavir-flow:mark flow p)))))) 27 | -------------------------------------------------------------------------------- /Liveness/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cleavir-liveness 2 | (:use #:cl) 3 | (:shadow #:liveness) 4 | (:export #:liveness #:live-before #:live-after)) 5 | -------------------------------------------------------------------------------- /Loops/cleavir-loops.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-loops 4 | :depends-on (:cleavir-graph) 5 | :components 6 | ((:file "packages") 7 | (:file "loops" :depends-on ("packages")))) 8 | -------------------------------------------------------------------------------- /Loops/loops.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cleavir-loops) 2 | 3 | ;;;; Loops. 4 | ;;;; 5 | ;;;; A loop can only be the result of a TAGBODY form. Whenever there 6 | ;;;; is a non-trivial strongly connected component in the flow graph, 7 | ;;;; we have a loop. The only restriction on loops in Common Lisp is 8 | ;;;; that the TAGBODY form introduces a unique node that 9 | ;;;; dominates every other node in the strongly connected 10 | ;;;; component. Another way of saying the same thing is that it is not 11 | ;;;; possible to transfer control from the outside of a TAGBODY form 12 | ;;;; into it (we can ignore control arcs from nested procedures). 13 | ;;;; 14 | ;;;; If we compute a dominance tree of all the nodes in a 15 | ;;;; strongly connected component S, then a nested loop shows up as a 16 | ;;;; (sub) strongly connected component immediately dominated by some 17 | ;;;; other node than the one that dominates the entire component 18 | ;;;; S. Let us say that I0 is the node that dominates every 19 | ;;;; node in the strongly connected component. Let I10, I11, 20 | ;;;; ..., I1n be the nodes in S that are immediately dominated 21 | ;;;; by I0. If we remove I0 and I10, I11, ... I1n from S and the 22 | ;;;; remaining nodes contain a strongly connected component T, 23 | ;;;; this means that there is a nested loop, and since I0 is not the 24 | ;;;; node that immediately dominates them, there must be some 25 | ;;;; other node I that does. 26 | ;;;; 27 | ;;;; Notice that a nested loop detected this way may or may not be the 28 | ;;;; result of a nested TAGBODY form. It could also appear because the 29 | ;;;; tags and the GO forms of the top-level loop form such a nested 30 | ;;;; loop "by accident". But we still want to count it as a nested 31 | ;;;; loop. And it is unlikely that such a nested loop would appear by 32 | ;;;; accident. 33 | ;;;; 34 | ;;;; Finally, it is possible that a nested loop that appears by 35 | ;;;; accident, i.e., that is not the result of a nested TAGBODY form, 36 | ;;;; can not be detected by the method describe above, because there is 37 | ;;;; no restriction preventing a GO into the middle of it. As a result 38 | ;;;; we might have a real nested loop, but since the nodes in it 39 | ;;;; are all directly dominated by I0, then we won't find it. 40 | 41 | ;;; Kosaraju's algoritm is a simple algorithm for finding the strongly 42 | ;;; connected components of a flow graph. The return value is a set 43 | ;;; (represented as a list) of strongly connected components, each 44 | ;;; represented as a list of nodes. A trivial component will be 45 | ;;; represented as a list of a single element. 46 | (defun kosaraju (graph) 47 | (cleavir-graph:with-graph (graph) 48 | (let ((table (make-hash-table :test #'eq)) 49 | (result '()) 50 | (temp '())) 51 | (labels ((traverse (node) 52 | (unless (gethash node table) 53 | (setf (gethash node table) t) 54 | (cleavir-graph:map-predecessors #'traverse node) 55 | (push node temp)))) 56 | (cleavir-graph:do-nodes-depth-first-preorder (initial graph) 57 | (unless (gethash initial table) 58 | (setf temp '()) 59 | (traverse initial) 60 | (push temp result))) 61 | result)))) 62 | -------------------------------------------------------------------------------- /Loops/natural-loops.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-loops) 2 | 3 | ;;; Loops. 4 | ;;; A natural loop is the set of nodes associated with a back-edge. 5 | (defclass natural-loop () 6 | ((%nodes :accessor nodes :initarg :nodes) 7 | (%header-node :accessor header-node :initarg :header-node) 8 | (%back-edge-node :accessor back-edge-node :initarg :back-edge-node))) 9 | 10 | ;;; We identify back edges and find the natural loop associated with 11 | ;;; that back edge. 12 | 13 | ;;; Return a list of natural loops. 14 | (defun compute-loops (graph) 15 | (let ((dominance-tree (cleavir-dominance:dominance-tree graph)) 16 | (table (make-hash-table :test #'eq)) 17 | loops) 18 | (cleavir-graph:with-graph (graph) 19 | (labels ((compute-natural-loop (header back-edge-node) 20 | (let (loop) 21 | (labels ((traverse (node) 22 | (when (member header (cleavir-dominance:dominators dominance-tree node)) 23 | (unless (member node loop) 24 | (push node loop) 25 | (cleavir-graph:map-predecessors #'traverse node))))) 26 | (traverse back-edge-node)) 27 | (make-instance 'natural-loop 28 | :nodes loop 29 | :header-node header 30 | :back-edge-node back-edge-node))) 31 | (traverse (node) 32 | (setf (gethash node table) t) 33 | (cleavir-graph:do-successors (successor node) 34 | (cond ((gethash successor table) 35 | ;; If one of the successors has already been 36 | ;; traversed, check if that successor dominates 37 | ;; this node 38 | (when (member successor 39 | (cleavir-dominance:dominators dominance-tree node)) 40 | (push (compute-natural-loop successor node) 41 | loops))) 42 | (t (traverse successor)))))) 43 | (traverse start-node) 44 | loops)))) 45 | -------------------------------------------------------------------------------- /Loops/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-loops 4 | (:use #:common-lisp) 5 | (:export 6 | #:kosaraju 7 | )) 8 | -------------------------------------------------------------------------------- /Meter/cleavir-meter.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-meter 4 | :description "Utilities for measuring performance of compiler tools." 5 | :author "Robert Strandh " 6 | :maintainer "Bike " 7 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-meter/" 8 | :version "1.0.0" 9 | :license "BSD" 10 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 11 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 12 | :serial t 13 | :components 14 | ((:file "packages") 15 | (:file "meter"))) 16 | -------------------------------------------------------------------------------- /Meter/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-meter 4 | (:use #:common-lisp) 5 | (:export #:reset 6 | #:report 7 | #:stream-report 8 | #:invoke-with-meter 9 | #:with-meter 10 | #:meter 11 | #:basic-meter 12 | #:size-meter 13 | #:increment-size)) 14 | -------------------------------------------------------------------------------- /Meter/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-meter)))) 4 | (list (find-package "CLEAVIR-METER"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-meter)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /Primop/cleavir-primop.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-primop 4 | :description "Abstract Syntax Tree representation for Common Lisp code." 5 | :author ("Robert Strandh " 6 | "Bike ") 7 | :maintainer "Bike " 8 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-primop/" 9 | :version "1.0.0" 10 | :license "BSD" 11 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 12 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 13 | :depends-on (:cleavir-attributes) 14 | :components 15 | ((:file "packages") 16 | (:file "info" :depends-on ("packages")) 17 | (:file "definitions" :depends-on ("packages" "info")))) 18 | -------------------------------------------------------------------------------- /Primop/definitions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-primop-info) 2 | 3 | (macrolet ((defprimops (&rest specs) 4 | `(progn 5 | ,@(loop for spec in specs 6 | collect `(defprimop ,@spec))))) 7 | (defprimops 8 | (cleavir-primop:car 1 :value :flushable) 9 | (cleavir-primop:cdr 1 :value :flushable) 10 | (cleavir-primop:rplaca 2 :effect) 11 | (cleavir-primop:rplacd 2 :effect) 12 | (symbol-value 1 :value :flushable) 13 | ((setf symbol-value) 2 :effect) 14 | (fdefinition 1 :value :flushable) 15 | 16 | (cleavir-primop:slot-read 2 :value :flushable) 17 | (cleavir-primop:slot-write 3 :effect) 18 | (cleavir-primop:funcallable-slot-read 2 :value :flushable) 19 | (cleavir-primop:funcallable-slot-write 3 :effect) 20 | 21 | (cleavir-primop:fixnum-less 2 2 :flushable) 22 | (cleavir-primop:fixnum-not-greater 2 2 :flushable) 23 | (cleavir-primop:fixnum-equal 2 2 :flushable))) 24 | -------------------------------------------------------------------------------- /Primop/info.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-primop-info) 2 | 3 | ;;;; "primop" here means what other systems might call an "intrinsic"- 4 | ;;;; something with function-like behavior that the compiler handles specially 5 | ;;;; in such a way that probably doesn't involve an actual function call. 6 | ;;;; For our purposes, this means that it has a fixed number of arguments 7 | ;;;; that must be evaluated from left to right, and no other syntax. 8 | 9 | ;;;; Note that the cleavir-primop: package has many symbols that are not primops 10 | ;;;; in this particular sense, such as LET-UNINITIALIZED. 11 | 12 | ;;; structure describing a primop 13 | (defclass info () 14 | ((%name :initarg :name :reader name) 15 | ;; :value means it returns a value. :effect means it doesn't. 16 | ;; An integer means it's a conditional with that many branches. 17 | (%out-kind :initarg :out-kind :reader out-kind 18 | :type (or (member :value :effect) (integer 2))) 19 | ;; Number of inputs accepted 20 | (%ninputs :initarg :ninputs :reader ninputs :type (integer 0)) 21 | ;; Primop-specific arguments 22 | (%arguments :initarg :arguments :reader arguments :initform nil) 23 | ;; Miscellaneous attributes 24 | (%attributes :initarg :attributes :reader attributes 25 | :initform (cleavir-attributes:default-attributes)))) 26 | 27 | (defmethod print-object ((o info) s) 28 | (print-unreadable-object (o s :type t) 29 | (write (name o) :stream s)) 30 | o) 31 | 32 | (defmethod make-load-form ((o info) &optional env) 33 | (make-load-form-saving-slots o :environment env)) 34 | 35 | (defvar *primops* (make-hash-table :test #'equal)) 36 | 37 | (defun info (name) 38 | (or (gethash name *primops*) 39 | (when (consp name) ; name and arguments 40 | (let ((proto (gethash (car name) *primops*))) 41 | (if proto 42 | (setf (gethash name *primops*) 43 | (make-instance 'info 44 | :name (car name) 45 | :attributes (attributes proto) 46 | :out-kind (out-kind proto) 47 | :ninputs (ninputs proto) 48 | :arguments (rest name))) 49 | nil))) 50 | (error "BUG: No primop: ~a" name))) 51 | 52 | (defmacro defprimop (name ninputs out &rest flags) 53 | `(eval-when (:compile-toplevel :load-toplevel :execute) 54 | (setf (gethash ',name *primops*) 55 | (make-instance 'info 56 | :name ',name 57 | :attributes (make-instance 'cleavir-attributes:attributes 58 | :flags (cleavir-attributes:make-flags ,@flags)) 59 | :out-kind ',out :ninputs ',ninputs)))) 60 | -------------------------------------------------------------------------------- /Primop/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-primop 4 | (:use) 5 | (:export 6 | #:eq #:typeq #:case 7 | #:car #:cdr #:rplaca #:rplacd 8 | #:fixnum-arithmetic 9 | #:fixnum-add 10 | #:fixnum-sub 11 | #:fixnum-less 12 | #:fixnum-not-greater 13 | #:fixnum-greater 14 | #:fixnum-not-less 15 | #:fixnum-equal 16 | ;; Each of these operations takes a type argument in addition to 17 | ;; the normal argument(s) of the corresponding Common Lisp 18 | ;; function. That type argument is the first one, and it is not 19 | ;; evaluated. 20 | #:float-add 21 | #:float-sub 22 | #:float-mul 23 | #:float-div 24 | #:float-less 25 | #:float-not-greater 26 | #:float-greater 27 | #:float-not-less 28 | #:float-equal 29 | #:float-sin 30 | #:float-cos 31 | #:float-sqrt 32 | #:coerce 33 | #:slot-read #:slot-write 34 | #:funcallable-slot-read #:funcallable-slot-write 35 | #:aref #:aset 36 | #:call-with-variable-bound 37 | #:let-uninitialized 38 | #:the #:truly-the #:ensure-the 39 | #:funcall 40 | #:multiple-value-call 41 | #:multiple-value-extract 42 | #:unreachable 43 | #:ast 44 | #:cst-to-ast)) 45 | 46 | (defpackage #:cleavir-primop-info 47 | (:use #:cl) 48 | (:export #:info #:defprimop 49 | #:name #:ninputs #:out-kind #:attributes #:arguments)) 50 | -------------------------------------------------------------------------------- /Primop/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-primop)))) 4 | (mapcar #'find-package '("CLEAVIR-PRIMOP-INFO" "CLEAVIR-PRIMOP"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-primop)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Cleavir 2 | 3 | Cleavir is an implementation-independent framework for creating Common Lisp compilers. It is modular and extensible, so that CL implementations with different aims and backends can share the same code. 4 | 5 | ## Getting started 6 | 7 | The `Example/` directory contains a worked example of a simplified Cleavir client, showing how Cleavir can be used to translate Common Lisp code into an intermediate representation, and how optimizations can be applied to this IR. The README there explains how to load and use that system. 8 | 9 | ## Basic structure 10 | 11 | Cleavir is not a single system. It is instead a collection of systems that can be incorporated together as subsystems of a compiler. 12 | 13 | The CST-to-AST system parses Common Lisp source code, in the form of [CSTs](https://github.com/s-expressionists/Concrete-Syntax-Tree), into objects called Abstract Syntax Trees (ASTs). ASTs closely represent the original source as `standard-object`s. They are suitable for further compilation processing, but also for other purposes like code walking and some analysis. 14 | 15 | The AST-to-BIR system generates a Block-based Intermediate Representation (BIR) from ASTs. The BIR makes program control and data flow explicit while remaining independent of the target machine. More information on BIR is available in the `BIR/` directory. 16 | 17 | The BIR-transformations system analyzes and applies various optimizations to BIR. More information on the transformations Cleavir defines are available in the `BIR-transformations/` directory. 18 | 19 | Clients may customize surface syntax by defining subclasses and methods at the AST level, and lower level operations by doing the same at the IR level. Individual modules can be used independently of one another, e.g. a code-walking application need not use anything below the AST level. 20 | -------------------------------------------------------------------------------- /Reaching-definitions/cleavir-reaching-definitions-test.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-reaching-definitions-test 4 | :depends-on (:cleavir-graph :cleavir-graph-test-utilities 5 | :cleavir-reaching-definitions) 6 | :components 7 | ((:file "test-packages") 8 | (:file "test-reaching-definitions" :depends-on ("test-packages")))) 9 | 10 | -------------------------------------------------------------------------------- /Reaching-definitions/cleavir-reaching-definitions.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-reaching-definitions 4 | :depends-on (:cleavir-flow :cleavir-graph) 5 | :serial t 6 | :components 7 | ((:file "packages") 8 | (:file "reaching-definitions"))) 9 | -------------------------------------------------------------------------------- /Reaching-definitions/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-reaching-definitions 4 | (:use #:common-lisp) 5 | (:export 6 | #:reaching-definitions 7 | #:reaching 8 | )) 9 | -------------------------------------------------------------------------------- /Reaching-definitions/reaching-definitions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-reaching-definitions) 2 | 3 | (cleavir-flow:define-flow reaching-definitions (:direction :forward) 4 | ((before :accessor before :reader reaching :initform (make-hash-table)))) 5 | 6 | (defmethod cleavir-flow:flow ((flow reaching-definitions) graph node) 7 | (cleavir-graph:with-graph (graph) 8 | (let ((before (before node flow))) 9 | (cleavir-graph:do-successors (succ node) 10 | (let ((sbefore (before succ flow)) (changep nil)) 11 | (cleavir-graph:do-outputs (out node) 12 | (unless (gethash out sbefore) 13 | (setf (gethash out sbefore) node changep t))) 14 | (maphash (lambda (out definer) 15 | (unless (gethash out sbefore) 16 | (setf (gethash out sbefore) definer changep t))) 17 | before) 18 | (when changep (cleavir-flow:mark flow succ))))))) 19 | -------------------------------------------------------------------------------- /Reaching-definitions/test-packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cleavir-reaching-definitions-test 2 | (:use #:common-lisp) 3 | (:export 4 | #:test-reaching-definitions)) 5 | -------------------------------------------------------------------------------- /Reaching-definitions/test-reaching-definitions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-reaching-definitions-test) 2 | 3 | ;;;; To test the reaching definitions, we essentially program it 4 | ;;;; again, in a different way. This time we take a single 5 | ;;;; definition, and we see what nodes it reaches by traversing the 6 | ;;;; graph starting at that node. We call this function for every 7 | ;;;; definition in some random graph, and we compare the result to 8 | ;;;; what the call to REACHING-DEFINITIONS returns. We compare it 9 | ;;;; both ways, i.e., if some node can be reached the stupid way, then 10 | ;;;; its definition had better be in the result of 11 | ;;;; REACHING-DEFINITIONS, and if some node is not in the result of 12 | ;;;; REACHING-DEFINITIONS, then it must not be possible to reach it 13 | ;;;; the stupid way. 14 | 15 | ;;; Return a hash table in which the keys are the nodes that can be 16 | ;;; reached from a definition of VAR in NODE. 17 | (defun nodes-reached-by-definition (graph node var) 18 | (cleavir-graph:with-graph (graph) 19 | (let ((table (make-hash-table :test #'eq))) 20 | (labels ((traverse (node path) 21 | (if (member node path :test #'eq) 22 | nil 23 | (unless (gethash node table) 24 | (setf (gethash node table) t) 25 | (unless (cleavir-graph:do-outputs (out node nil) 26 | (when (eq var out) (return t))) 27 | (let ((new-path (cons node path))) 28 | (cleavir-graph:do-successors (succ node) 29 | (traverse succ new-path)))))))) 30 | (cleavir-graph:do-successors (succ node) (traverse succ '()))) 31 | table))) 32 | 33 | (defun test-reaching-definitions-on-one-graph (graph) 34 | (let ((reaching-definitions 35 | (cleavir-reaching-definitions:reaching-definitions graph))) 36 | (cleavir-graph:with-graph (graph) 37 | (cleavir-graph:do-nodes (definer) 38 | (cleavir-graph:do-outputs (var definer) 39 | (let ((nodes-reached 40 | (nodes-reached-by-definition graph definer var))) 41 | (loop for n being each hash-key of nodes-reached 42 | for ntable = (cleavir-reaching-definitions:reaching 43 | n reaching-definitions) 44 | do (assert (eq definer (gethash var ntable)))) 45 | (cleavir-graph:do-nodes (user) 46 | (let ((utable (cleavir-reaching-definitions:reaching 47 | user reaching-definitions))) 48 | (if (gethash user nodes-reached) 49 | (assert (eq definer (gethash var utable))) 50 | (assert (not (eq definer (gethash var utable))))))))))))) 51 | 52 | (defun test-reaching-definitions (&optional (n 10000)) 53 | (loop repeat n 54 | do (test-reaching-definitions-on-one-graph 55 | (cleavir-graph-test-utilities:random-flow-chart)))) 56 | -------------------------------------------------------------------------------- /Register-allocation/cleavir-register-allocation.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-register-allocation 4 | :depends-on (:cleavir-liveness :cleavir-graph) 5 | :components 6 | ((:file "packages") 7 | (:file "compute-conflicts") 8 | (:file "graph-coloring"))) 9 | -------------------------------------------------------------------------------- /Register-allocation/compute-conflicts.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-register-allocation) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Compute a set of conflicts for the register allocator. Recall 6 | ;;; that two variables generate a conflict when one is live at the 7 | ;;; point where the other is written to. Furthermore, all items that 8 | ;;; are written to by the same instruction conflict with each other. 9 | ;;; 10 | ;;; We do not want multiple copies of some conflict. We have to be 11 | ;;; careful because the relation is symmetric, so that if (L1 . L2) is 12 | ;;; a conflict in the set, we do not want to add (L2 . L1) because it 13 | ;;; is the same conflict. 14 | ;;; 15 | ;;; Conflicts are computed only for lexical variables. Other types of 16 | ;;; locations are ignored. 17 | 18 | (defun same-conflict-p (c1 c2) 19 | (or (and (eq (car c1) (car c2)) 20 | (eq (cdr c1) (cdr c2))) 21 | (and (eq (car c1) (cdr c2)) 22 | (eq (cdr c1) (car c2))))) 23 | 24 | (defgeneric conflicts-instruction (instruction graph liveness)) 25 | 26 | (defmethod conflicts-instruction (instruction graph liveness) 27 | (cleavir-graph:with-graph (graph) 28 | (let ((conflicts nil) 29 | (live-after (cleavir-liveness:live-after instruction liveness))) 30 | (cleavir-graph:do-outputs (output instruction) 31 | ;; Note that the live-after will include the outputs themselves, 32 | ;; so we don't need to handle output vs output conflicts specially. 33 | (cleavir-set:doset (live live-after) 34 | (unless (eq output live) (push (cons output live) conflicts)))) 35 | conflicts))) 36 | 37 | (defun compute-conflicts (graph) 38 | (let ((conflicts '()) 39 | (table (make-hash-table :test #'eq)) 40 | (liveness (cleavir-liveness:liveness graph))) 41 | (cleavir-graph:with-graph (graph) 42 | (cleavir-graph:do-nodes (node) 43 | (setf conflicts 44 | (union conflicts (conflicts-instruction graph node liveness) 45 | :test #'same-conflict-p)))) 46 | conflicts)) 47 | -------------------------------------------------------------------------------- /Register-allocation/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cleavir-register-allocation 2 | (:use #:common-lisp) 3 | (:export 4 | #:degree 5 | #:solve 6 | #:compute-conflicts 7 | )) 8 | -------------------------------------------------------------------------------- /Set/README.md: -------------------------------------------------------------------------------- 1 | This system defines a basic set data structure, which is useful for various purposes. 2 | Sets are especially used in BIR. The sets here are just the usual mathematical sense 3 | of a collection of different elements. The usual operations, such as `union` and 4 | membership checks, are defined. Some have CL's "n" prefix to indicate that they may 5 | be carried out destructively for efficiency. 6 | 7 | The `set` class is a wrapper over one of two implementations, a hash and a list. The 8 | hash is used by default; if you want to use lists (which are more reproducible, but do 9 | not have constant-time set membership checks), change the features code at the top of 10 | `set.lisp`. 11 | 12 | In the future, it would probably be useful to establish a more compact set representation, 13 | as a bitfield with accompanying universe. Then different sets from the same universe 14 | could be more compactly and efficiently used. The trick would be keeping the universe 15 | stable in the face of modifications to the BIR or whatever else. 16 | -------------------------------------------------------------------------------- /Set/cleavir-set.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-set 4 | :description "A set data structure." 5 | :author ("Bike " "Charles Zhang") 6 | :maintainer "Bike " 7 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-set/" 8 | :version "1.0.0" 9 | :license "BSD" 10 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 11 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 12 | :depends-on () 13 | :components 14 | ((:file "packages") 15 | (:file "set" :depends-on ("packages")))) 16 | -------------------------------------------------------------------------------- /Set/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:cleavir-set 4 | (:use #:cl) 5 | (:shadow #:set #:nunion #:union #:some #:every #:notany #:notevery) 6 | (:export #:set #:empty-set #:make-set #:arb #:set<= #:set= 7 | #:nadjoin #:nadjoinf #:nremove #:nremovef 8 | #:union #:nunion #:nunionf #:nsubtract #:nsubtractf #:difference 9 | #:presentp #:size #:empty-set-p #:copy-set 10 | #:doset #:mapset #:set-to-list #:filter 11 | #:some #:every #:notany #:notevery)) 12 | -------------------------------------------------------------------------------- /Set/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-set)))) 4 | (list (find-package "CLEAVIR-SET"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-set)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /Stealth-mixins/README.md: -------------------------------------------------------------------------------- 1 | It is sometimes useful to add mixins to a class without altering its definition. For example, this can be used to add information to [BIR](https://s-expressionists.github.io/Cleavir/cleavir-bir) objects particular to a client or extension, so that the general BIR definitions do not need to be aware of the client/extension code. The `cleavir-stealth-mixins` facility provides a small interface to do so reliably. 2 | 3 | `define-stealth-mixin` defines a new class and makes it a superclass of an existing "victim" class. This new class is set up so that it will remain a superclass even if the definition of the victim class is reevaluated. 4 | 5 | Original hack by Gilbert Baumann. 6 | -------------------------------------------------------------------------------- /Stealth-mixins/cleavir-stealth-mixins.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cleavir-stealth-mixins 4 | :description "Utilities for adding mixins to classes after they are defined." 5 | :author "Robert Strandh " 6 | :maintainer "Bike " 7 | :homepage "https://s-expressionists.github.io/Cleavir/cleavir-stealth-mixins/" 8 | :version "1.0.0" 9 | :license "BSD" 10 | :bug-tracker "https://github.com/s-expressionists/Cleavir/issues" 11 | :source-control (:git "https://github.com/s-expressionists/Cleavir.git") 12 | :depends-on (:closer-mop) 13 | :serial t 14 | :components 15 | ((:file "packages") 16 | (:file "stealth-mixins"))) 17 | -------------------------------------------------------------------------------- /Stealth-mixins/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage :cleavir-stealth-mixins 4 | (:use #:common-lisp) 5 | (:export 6 | #:class-stealth-mixins 7 | #:add-mixin 8 | #:define-stealth-mixin)) 9 | -------------------------------------------------------------------------------- /Stealth-mixins/staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cleavir-documentation-generation) 2 | 3 | (defmethod staple:packages ((sys (eql (asdf:find-system :cleavir-stealth-mixins)))) 4 | (list (find-package "CLEAVIR-STEALTH-MIXINS"))) 5 | 6 | (defmethod staple:page-type ((sys (eql (asdf:find-system :cleavir-stealth-mixins)))) 7 | 'cleavir-page) 8 | -------------------------------------------------------------------------------- /Stealth-mixins/stealth-mixins.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cleavir-stealth-mixins) 2 | 3 | ;;; The following hack is due to Gilbert Baumann. It allows us to 4 | ;;; dynamically mix in classes into a class without the latter being 5 | ;;; aware of it. 6 | 7 | ;; First of all we need to keep track of added mixins, we use a hash 8 | ;; table here. Better would be to stick this information to the victim 9 | ;; class itself. 10 | 11 | (defvar *stealth-mixins* (make-hash-table)) 12 | 13 | (defmacro class-stealth-mixins (class) 14 | `(gethash ,class *stealth-mixins*)) 15 | 16 | ;; The 'direct-superclasses' argument to ensure-class is a list of 17 | ;; either classes or their names. Since we want to avoid duplicates, 18 | ;; we need an appropriate equivalence predicate: 19 | 20 | (defun class-equalp (c1 c2) 21 | (when (symbolp c1) (setf c1 (find-class c1))) 22 | (when (symbolp c2) (setf c2 (find-class c2))) 23 | (eq c1 c2)) 24 | 25 | (defun add-mixin (mixin-name victim-class) 26 | ;; Add the class to the mixins of the victim 27 | (closer-mop:ensure-class 28 | victim-class 29 | :direct-superclasses (adjoin mixin-name 30 | (and (find-class victim-class nil) 31 | (closer-mop:class-direct-superclasses 32 | (find-class victim-class))) 33 | :test #'class-equalp)) 34 | 35 | ;; Register it as a new mixin for the victim class 36 | (pushnew mixin-name (class-stealth-mixins victim-class)) 37 | 38 | ;; When one wants to [re]define the victim class the new mixin 39 | ;; should be present too. We do this by 'patching' ensure-class: 40 | (defmethod closer-mop:ensure-class-using-class :around 41 | (class (name (eql victim-class)) 42 | &rest arguments 43 | &key (direct-superclasses nil direct-superclasses-p) 44 | &allow-other-keys) 45 | (cond (direct-superclasses-p 46 | ;; Silently modify the super classes to include our new 47 | ;; mixin. 48 | (dolist (k (class-stealth-mixins name)) 49 | (pushnew k direct-superclasses 50 | :test #'class-equalp)) 51 | (apply #'call-next-method class name 52 | :direct-superclasses direct-superclasses 53 | arguments)) 54 | (t 55 | (call-next-method))))) 56 | 57 | (defmacro define-stealth-mixin (name super-classes victim-class-desig 58 | &rest for-defclass) 59 | "Like DEFCLASS but adds the newly defined class to the super classes 60 | of 'victim-class'." 61 | `(progn 62 | ;; First define the class we talk about 63 | (defclass ,name ,super-classes ,@for-defclass) 64 | ,@(loop for victim-class in (if (listp victim-class-desig) 65 | victim-class-desig 66 | (list victim-class-desig)) 67 | collect `(add-mixin ',name ',victim-class)) 68 | ',name)) 69 | -------------------------------------------------------------------------------- /version.sexp: -------------------------------------------------------------------------------- 1 | "2.0.0" 2 | --------------------------------------------------------------------------------