├── code ├── ir │ ├── ir-unroll-loops.lisp │ ├── ir-vectorize.lisp │ ├── ir-split-loops.lisp │ ├── ir-optimize.lisp │ ├── ir-isl-output.lisp │ ├── ir-remove-dead-code.lisp │ ├── lexenv.lisp │ ├── sb-simd.lisp │ ├── ir-isl-create-loopus-expr.lisp │ ├── ir-eliminate-common-subexpressions.lisp │ ├── ir-expand.lisp │ ├── ir-isl-create-loopus-node.lisp │ ├── ir-specialize.lisp │ ├── ir-isl-optimize.lisp │ ├── ir-convert.lisp │ ├── ir.lisp │ └── ir-isl-input.lisp ├── loopus.sb-simd.asd ├── macros.lisp ├── math │ ├── variable.lisp │ └── polynomial.lisp ├── loopus.asd ├── packages.lisp └── test.lisp ├── README.org └── LICENSE /code/ir/ir-unroll-loops.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | (defun ir-unroll-loops (ir) 4 | "Returns a copy of IR in which loops marked for unrolling have been 5 | unrolled, and in which loops with only a small iteration space have been 6 | unrolled completely." 7 | ir) 8 | -------------------------------------------------------------------------------- /code/ir/ir-vectorize.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | (defun ir-vectorize (ir) 4 | "Returns a copy of IR in which sufficiently simple inner loops have been 5 | replaced by a vectorized loop and a reminder loop." 6 | (let ((*ir-value-copies* (make-hash-table :test #'eq))) 7 | (copy-ir-block 'ir-vectorize ir nil))) 8 | 9 | 10 | -------------------------------------------------------------------------------- /code/ir/ir-split-loops.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | (defun ir-split-loops (ir) 4 | "Returns a copy of IR in which some loops with a predicate that depend 5 | only on the iteration space are eliminated by splitting the loop into one 6 | loop where the predicate is always true, and one loop where the predicate 7 | is always false." 8 | ir) 9 | -------------------------------------------------------------------------------- /code/loopus.sb-simd.asd: -------------------------------------------------------------------------------- 1 | (defsystem #:loopus.sb-simd 2 | :description "SIMD vectorization for Loopus" 3 | :author "Marco Heisig " 4 | :license "MIT" 5 | 6 | :depends-on 7 | ("alexandria" 8 | "closer-mop" 9 | "loopus" 10 | "typo.sb-simd" 11 | "trivia") 12 | 13 | :serial t 14 | :components 15 | ((:module "ir" :components ((:file "sb-simd"))))) 16 | -------------------------------------------------------------------------------- /code/macros.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.internals) 2 | 3 | (defmacro begin (&body body) 4 | `(for (,(gensym) 0 1) ,@body)) 5 | 6 | (defmacro for (&whole form (variable start end &optional (step 1)) 7 | &body body &environment env) 8 | (declare (ignorable variable start end step body)) 9 | (ir-expand 10 | (ir-optimize 11 | (ir-convert-in-environment form env 0)))) 12 | -------------------------------------------------------------------------------- /code/ir/ir-optimize.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | ;; Nothing 4 | (defun ir-optimize (ir) ir) 5 | 6 | ;; No isl 7 | ;; No common sub expression. Specialize makes (aref array idx) pure and 8 | ;; sub expression delete it 9 | (defun ir-optimize (ir) 10 | (ir-vectorize 11 | (ir-remove-dead-code 12 | (ir-specialize ir)))) 13 | 14 | ;; deadcode not working for now 15 | 16 | ;; Isl 17 | (defun ir-optimize (ir) 18 | ; (ir-vectorize 19 | (ir-isl-optimize 20 | ;; (ir-remove-dead-code 21 | (ir-specialize ir))) 22 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Loopus - A portable loop optimization framework for Common Lisp 2 | #+AUTHOR: Marco Heisig 3 | 4 | #+BEGIN_QUOTE 5 | Sometimes, when the full moon rises and foolish programmers declare 6 | (optimize (safety 0)), you can hear the howl of the Loopus, and screams of 7 | source code that is ripped to shreds. 8 | #+END_QUOTE 9 | 10 | Loopus is a portable loop optimization framework for Common Lisp. It can 11 | either be used as a building block for a compiler, or directly by 12 | application programmers, via macros. 13 | 14 | Right now, Loopus is not as sophisticated as I'd like it to be. My hope is 15 | that this initial version will motivate others to contribute. So if you 16 | are in the mood for writing a polyhedral optimization framework, don't 17 | hesitate to contact me :) 18 | -------------------------------------------------------------------------------- /code/math/variable.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.math) 2 | 3 | (defgeneric variable-name (v)) 4 | 5 | (defgeneric variable-number (v)) 6 | 7 | (let ((counter 0) 8 | (lock (bordeaux-threads:make-lock))) 9 | (defun next-variable-number () 10 | (bordeaux-threads:with-lock-held (lock) 11 | (incf counter)))) 12 | 13 | (defclass variable () 14 | ((%name 15 | :initarg :name 16 | :initform (alexandria:required-argument :name) 17 | :type symbol 18 | :reader variable-name) 19 | (%number 20 | :initform (next-variable-number) 21 | :type unsigned-byte 22 | :reader variable-number))) 23 | 24 | (defmethod print-object ((variable variable) stream) 25 | (print-unreadable-object (variable stream :type t :identity nil) 26 | (write (expression-from-variable variable) :stream stream))) 27 | 28 | (defun expression-from-variable (variable) 29 | (let* ((number (variable-number variable)) 30 | (symbol (variable-name variable)) 31 | (name (symbol-name symbol)) 32 | (package (symbol-package symbol))) 33 | (intern (format nil "~A<~D>" name number) 34 | package))) 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2021 Marco Heisig 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /code/loopus.asd: -------------------------------------------------------------------------------- 1 | (defsystem #:Loopus 2 | :description "A portable loop optimization framework for Common Lisp." 3 | :author "Marco Heisig " 4 | :license "MIT" 5 | 6 | :depends-on 7 | ("alexandria" 8 | "bordeaux-threads" 9 | "closer-mop" 10 | "trivia" 11 | "trivial-cltl2" 12 | "trivial-macroexpand-all" 13 | "typo" 14 | "cl-isl") 15 | 16 | :serial t 17 | :components 18 | ((:file "packages") 19 | (:module "math" 20 | :components 21 | ((:file "variable") 22 | (:file "polynomial"))) 23 | (:module "ir" 24 | :components 25 | ((:file "ir") 26 | (:file "lexenv") 27 | (:file "ir-convert") 28 | (:file "ir-specialize") 29 | (:file "ir-remove-dead-code") 30 | (:file "ir-eliminate-common-subexpressions") 31 | (:file "ir-split-loops") 32 | (:file "ir-isl-input") 33 | (:file "ir-isl-output") 34 | (:file "ir-isl-create-loopus-expr") 35 | (:file "ir-isl-create-loopus-node") 36 | (:file "ir-isl-optimize") 37 | (:file "ir-unroll-loops") 38 | (:file "ir-vectorize") 39 | (:file "ir-optimize") 40 | (:file "ir-expand"))) 41 | (:file "macros"))) 42 | -------------------------------------------------------------------------------- /code/ir/ir-isl-output.lisp: -------------------------------------------------------------------------------- 1 | (in-package :loopus.ir) 2 | 3 | ;; Used in the node creation I think, not sure 4 | (defparameter node nil) 5 | 6 | ;; The hashtable used by copy-ir-node 7 | (defparameter *ir-value-copies* nil) 8 | 9 | ;; Is a list of loop variable in the cl-isl ast. New variable are pushed at the END of the list 10 | (defparameter possible-loop-variables nil) 11 | 12 | ;; string of the identifier to ir node - todo do it with identifier instead of strings 13 | ;; Used for loop variables 14 | (defparameter *id-to-nodes* nil) 15 | 16 | ;; Map of int to loop variable 17 | (defparameter *depth-loop-variables* nil) 18 | 19 | ;; Depth we are currently at in the ast 20 | (defparameter *current-depth* nil) 21 | 22 | ;; Hashtable of depth to the associated loopus node which is loop variable 23 | (defparameter *position-to-loopusvariable* nil) 24 | 25 | ;; Add/remove from *id-to-nodes* 26 | ;; Now it's with the string of the name 27 | ;; (Because the lisp object wrapping the identifier changes even if it's the same identifier) 28 | (defun create-loop-var (loop-variable) 29 | (let ((loop-variable (isl:identifier-name (isl:id-expr-get-id loop-variable)))) 30 | (alexandria:ensure-gethash loop-variable *id-to-nodes* (make-instance 'ir-value)))) 31 | (defun delete-loop-var (loop-variable) 32 | (let ((loop-variable (isl:identifier-name (isl:id-expr-get-id loop-variable)))) 33 | (remhash loop-variable *id-to-nodes*))) 34 | 35 | ;; Entry point of the program. Takes a cl-isl ast, call execute-node on it, and returns a loopus ast 36 | ;; Sequence of instructions are "block" in the cl-isl ast, and execute-node on a block calls recursively 37 | ;; itself on every statement of the block. Hence a single call to execute-node in this function 38 | (defun my-main (node dominator) 39 | (multiple-value-bind (ir-initial-node ir-final-node) 40 | (make-ir-initial-and-ir-final-node dominator) 41 | (let ((*blocks* (cons ir-final-node *blocks*))) 42 | (execute-node node)) 43 | ir-initial-node)) 44 | -------------------------------------------------------------------------------- /code/ir/ir-remove-dead-code.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | (defvar *ir-node-liveness*) 4 | 5 | (defgeneric ir-node-alive-p (ir-node)) 6 | 7 | (defun ir-remove-dead-code (ir) 8 | "Returns a copy of IR in which all calls to pure functions whose outputs 9 | are never used have been removed." 10 | (let ((*ir-node-liveness* (make-hash-table :test #'eq)) 11 | (*ir-value-copies* (make-hash-table :test #'eq))) 12 | (copy-ir-block 'ir-remove-dead-code ir nil))) 13 | 14 | (defmethod copy-ir-node :around 15 | ((context (eql 'ir-remove-dead-code)) 16 | (ir-node ir-node)) 17 | (when (ir-node-alive-p ir-node) 18 | (call-next-method))) 19 | 20 | (defmethod ir-node-alive-p :around ((ir-node ir-node)) 21 | (values 22 | (alexandria:ensure-gethash 23 | ir-node 24 | *ir-node-liveness* 25 | (call-next-method)))) 26 | 27 | (defmethod ir-node-alive-p ((ir-initial-node ir-initial-node)) 28 | ;; An initial node is alive if at least one inner node in its block is 29 | ;; alive. 30 | (block nil 31 | (map-block-inner-nodes 32 | (lambda (node) 33 | (when (ir-node-alive-p node) 34 | (return t))) 35 | ir-initial-node) 36 | (return nil))) 37 | 38 | (defmethod ir-node-alive-p ((ir-node-with-outputs ir-node-with-outputs)) 39 | ;; A node with outputs is alive if any of its outputs has a user that is 40 | ;; alive. 41 | (let ((outputs (ir-node-outputs ir-node-with-outputs))) 42 | (or (eql outputs '*) 43 | (loop for output in outputs 44 | thereis 45 | (loop for user in (ir-value-users output) 46 | thereis (ir-node-alive-p user)))))) 47 | 48 | (defmethod ir-node-alive-p ((ir-loop ir-loop)) 49 | ;; A loop is a live if its body is alive. 50 | (or (ir-node-alive-p (ir-loop-test ir-loop)) 51 | (ir-node-alive-p (ir-loop-body ir-loop)))) 52 | 53 | (defmethod ir-node-alive-p ((ir-call ir-call)) 54 | ;; A call is alive it is not pure. 55 | (or (not (typo:fnrecord-purep (ir-call-fnrecord ir-call))) 56 | (call-next-method))) 57 | 58 | (defmethod ir-node-alive-p ((ir-if ir-if)) 59 | ;; An if node is alive if either of its branches is alive. 60 | (or (ir-node-alive-p (ir-if-then ir-if)) 61 | (ir-node-alive-p (ir-if-else ir-if)))) 62 | -------------------------------------------------------------------------------- /code/ir/lexenv.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | ;;; The lexical environment used for IR conversion. 4 | 5 | (deftype non-nil-symbol () 6 | '(and symbol (not null))) 7 | 8 | (deftype function-name () 9 | '(or non-nil-symbol (cons (eql setf) (cons non-nil-symbol null)))) 10 | 11 | (deftype variable-name () 12 | 'non-nil-symbol) 13 | 14 | (defgeneric augment-lexenv (lexenv vrecords frecords)) 15 | 16 | (defclass lexenv () 17 | (;; The host environment surrounding this lexenv. 18 | (%parent 19 | :initarg :parent 20 | :initform nil 21 | :reader lexenv-parent) 22 | (%vrecords 23 | :initarg :vrecords 24 | :initform '() 25 | :reader lexenv-vrecords) 26 | (%frecords 27 | :initarg :frecords 28 | :initform '() 29 | :reader lexenv-frecords))) 30 | 31 | (defun make-lexenv (&optional environment) 32 | (make-instance 'lexenv 33 | :parent environment)) 34 | 35 | (defmethod augment-lexenv (lexenv vrecords frecords) 36 | (make-instance 'lexenv 37 | :parent (lexenv-parent lexenv) 38 | :vrecords (append vrecords (lexenv-vrecords lexenv)) 39 | :frecords (append frecords (lexenv-frecords lexenv)))) 40 | 41 | (defclass frecord () 42 | ((%name 43 | :initarg :name 44 | :initform (alexandria:required-argument :name) 45 | :type function-name 46 | :reader frecord-name) 47 | (%value 48 | :initarg :value 49 | :initform (alexandria:required-argument :value) 50 | :reader frecord-value))) 51 | 52 | (defun make-frecord (function-name value) 53 | (check-type function-name function-name) 54 | (check-type value ir-value) 55 | (make-instance 'frecord 56 | :name function-name 57 | :value value)) 58 | 59 | (defun frecordp (x) 60 | (typep x 'frecord)) 61 | 62 | (defclass vrecord () 63 | ((%name 64 | :initarg :name 65 | :initform (alexandria:required-argument :name) 66 | :type variable-name 67 | :reader vrecord-name) 68 | (%value 69 | :initarg :value 70 | :initform (alexandria:required-argument :value) 71 | :reader vrecord-value))) 72 | 73 | (defun make-vrecord (variable-name value) 74 | (check-type variable-name variable-name) 75 | (check-type value ir-value) 76 | (make-instance 'vrecord 77 | :name variable-name 78 | :value value)) 79 | 80 | (defun vrecordp (x) 81 | (typep x 'vrecord)) 82 | -------------------------------------------------------------------------------- /code/ir/sb-simd.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | (pushnew 'typo.common-lisp:integer+ sb-simd-vectorizer::*add-operators*) 4 | (pushnew 'typo.common-lisp:integer- sb-simd-vectorizer::*sub-operators*) 5 | (pushnew 'typo.common-lisp:integer* sb-simd-vectorizer::*mul-operators*) 6 | 7 | (defclass ir-simd-loop (ir-loop) 8 | ()) 9 | 10 | (defmethod copy-ir-node 11 | ((context (eql 'ir-vectorize)) 12 | (ir-loop ir-loop)) 13 | (destructuring-bind (start step) (ir-node-inputs ir-loop) 14 | (declare (ignore start)) 15 | (when (and (typo:eql-ntype-p (ir-value-derived-ntype step)) 16 | (eql (typo:eql-ntype-object (ir-value-derived-ntype step)) 1)) 17 | (map-block-inner-nodes 18 | (lambda (node) 19 | (unless (and (ir-call-p node) 20 | (typo:fnrecord-name (ir-call-fnrecord node)) 21 | (or 22 | (sb-simd-internals::find-function-record 23 | (typo:fnrecord-name (ir-call-fnrecord node)) 24 | nil) 25 | (member (typo:fnrecord-name (ir-call-fnrecord node)) 26 | '(typo.common-lisp:integer+ 27 | typo.common-lisp:integer- 28 | typo.common-lisp:integer*)))) 29 | (return-from copy-ir-node (call-next-method)))) 30 | (ir-loop-body ir-loop))) 31 | (let* ((variable (copy-ir-value context (ir-loop-variable ir-loop))) 32 | (ir-node (make-instance 'ir-node-with-outputs 33 | :outputs (list variable)))) 34 | (change-class ir-node 'ir-simd-loop 35 | :inputs (mapcar (alexandria:curry #'copy-ir-value context) (ir-node-inputs ir-loop)) 36 | :variable variable 37 | :test (copy-ir-block context (ir-loop-test ir-loop) ir-node) 38 | :body (copy-ir-block context (ir-loop-body ir-loop) ir-node))))) 39 | 40 | (defmethod ir-expand-node ((ir-simd-loop ir-simd-loop)) 41 | (call-next-method) 42 | #+(or) 43 | (destructuring-bind (start end step) (ir-node-inputs ir-simd-loop) 44 | (declare (ignore step)) 45 | `(() 46 | (sb-simd-vectorizer:do-vectorized 47 | (,(value-name (ir-loop-variable ir-simd-loop)) 48 | ,(value-name start) 49 | ,(value-name end)) 50 | ,(ir-expand-node (ir-loop-body ir-simd-loop)))))) 51 | -------------------------------------------------------------------------------- /code/ir/ir-isl-create-loopus-expr.lisp: -------------------------------------------------------------------------------- 1 | (in-package :loopus.ir) 2 | 3 | ;; Takes a cl-isl expression (for instance "1+2"), and create loopus nodes for it 4 | (defgeneric execute-expr (expr)) 5 | 6 | ;; Simple integer 7 | (defmethod execute-expr ((expr isl:int-expr)) 8 | (let* ((v (isl:int-expr-get-value expr)) 9 | (v (isl:value-object v))) 10 | (let* ((construct (make-instance 'ir-node)) 11 | (answer (make-instance 'ir-value 12 | :declared-type `(eql ,v) 13 | :derived-ntype (typo:ntype-of v))) 14 | (*blocks* (last *blocks*))) 15 | (change-class construct 'ir-construct 16 | :form `',v 17 | :outputs (list answer)) 18 | answer))) 19 | 20 | ;; Variable 21 | (defmethod execute-expr ((expr isl:id-expr)) 22 | ;; Simple loop variable 23 | (if (position (isl:id-expr-get-id expr) possible-loop-variables) 24 | (create-loop-var expr) 25 | ;; Otherwise it's a constant value 26 | (let* ((name (symbol-name (isl:identifier-name (isl:id-expr-get-id expr)))) 27 | ;; If it's a free variable we modify the value we use, otherwise it'll be name 28 | (answer (gethash (gethash name *free-variable-to-index*) *position-to-loopusvariable*)) 29 | (value (if answer answer name))) 30 | (alexandria:ensure-gethash ; is it actually usefull? 31 | value *id-to-nodes* 32 | (let* ((construct (make-instance 'ir-node)) 33 | (answer (make-instance 'ir-value 34 | ;;:declared-type v;;v ;;?? 35 | ;;:derived-ntype nil;;v ;;?? 36 | )) 37 | (*blocks* (last *blocks*))) 38 | (change-class construct 'ir-construct 39 | :form value 40 | :outputs (list answer)) 41 | answer))))) 42 | 43 | ;; Function call 44 | (defmethod execute-expr ((expr isl:ast-expr)) 45 | (let* ((answer (make-instance 'ir-value))) 46 | (make-instance 'ir-call 47 | :fnrecord (make-instance 'typo:fnrecord :name (isl:op-expr-get-operator expr) :function #'+) ;;todo place the real function here instead of + 48 | :inputs (mapcar #'execute-expr (isl:op-expr-get-list-args expr)) 49 | :outputs (list answer)) 50 | answer)) 51 | -------------------------------------------------------------------------------- /code/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | 3 | (progn 4 | (defpackage #:loopus 5 | (:use #:closer-common-lisp) 6 | #1= 7 | (:export 8 | #:for 9 | #:begin)) 10 | 11 | (defpackage #:loopus.internals 12 | (:use #:closer-common-lisp #:loopus) 13 | (:import-from #:trivia #:place #:<> #:access) 14 | (:shadow #:variable) 15 | #1# 16 | ;; Mathematical Functions (loopus.math) 17 | #2= 18 | (:export 19 | #:*default-polynomial-representation* 20 | #:variable 21 | #:variablep 22 | #:variable-name 23 | #:variable-number 24 | #:polynomial 25 | #:polynomialp 26 | #:polynomial+ 27 | #:polynomial- 28 | #:polynomial*) 29 | ;; The Loopus Intermediate Representation (loopus.ir) 30 | #3= 31 | (:export 32 | #:ir-node 33 | #:ir-node-p 34 | #:ir-node-dominator 35 | #:ir-node-inputs 36 | #:ir-node-outputs 37 | #:ir-node-successor 38 | #:ir-node-predecessor 39 | 40 | #:ir-initial-node 41 | #:ir-initial-node-p 42 | #:ir-final-node 43 | #:ir-final-node-p 44 | #:make-ir-initial-and-ir-final-node 45 | 46 | #:ir-loop 47 | #:ir-loop-p 48 | #:ir-loop-body 49 | #:ir-loop-variable 50 | 51 | #:ir-call 52 | #:ir-call-p 53 | #:ir-call-fnrecord 54 | 55 | #:ir-if 56 | #:ir-if-p 57 | #:ir-if-then 58 | #:ir-if-else 59 | 60 | #:ir-construct 61 | #:ir-construct-p 62 | 63 | #:ir-enclose 64 | #:ir-enclose-p 65 | #:ir-enclose-argument-values 66 | #:ir-enclose-body 67 | 68 | #:ir-value 69 | #:ir-value-p 70 | #:ir-value-producer 71 | #:ir-value-users 72 | #:ir-value-declared-type 73 | #:ir-value-derived-type 74 | #:ir-value-declare-type 75 | 76 | #:insert-ir-node-before 77 | #:insert-ir-node-after 78 | #:extract-ir-node 79 | #:map-block-inner-nodes 80 | 81 | #:ir-convert-in-environment 82 | #:ir-optimize 83 | #:ir-specialize 84 | #:ir-remove-dead-code 85 | #:ir-hoist-loop-invariant-code 86 | #:ir-eliminate-common-subexpressions 87 | #:ir-split-loops 88 | #:ir-unroll-loops 89 | #:ir-vectorize 90 | #:ir-expand)) 91 | 92 | (defpackage #:loopus.math 93 | (:use #:closer-common-lisp #:loopus.internals) 94 | (:import-from #:trivia #:place #:<> #:access) 95 | (:shadow #:variable) 96 | #2#) 97 | 98 | (defpackage #:loopus.ir 99 | (:use #:closer-common-lisp #:loopus.internals) 100 | (:import-from #:trivia #:place #:<> #:access) 101 | (:shadow #:variable) 102 | #3#)) 103 | -------------------------------------------------------------------------------- /code/ir/ir-eliminate-common-subexpressions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | ;;; A hash table, mapping from IR nodes to their depth. 4 | (defvar *ir-node-depth*) 5 | 6 | ;;; The depth on the IR block being processed right now. 7 | (defvar *depth*) 8 | 9 | (defgeneric ir-node-depth (ir-node)) 10 | 11 | (defgeneric ir-value-depth (ir-node)) 12 | 13 | (defun ir-eliminate-common-subexpressions (ir) 14 | "Returns a copy of IR in which all calls to the same, pure function with 15 | the same arguments have been replaced by a single call, and where that 16 | call has been moved to the outermost block it depends on." 17 | (let ((*ir-value-copies* (make-hash-table :test #'eq)) 18 | (*ir-node-depth* (make-hash-table :test #'eq))) 19 | (copy-ir-block 'ir-eliminate-common-subexpressions ir nil))) 20 | 21 | (defmethod copy-ir-block :around 22 | ((context (eql 'ir-eliminate-common-subexpressions)) 23 | (ir-initial-node ir-initial-node) 24 | dominator) 25 | (let ((*depth* (ir-node-depth ir-initial-node))) 26 | (call-next-method))) 27 | 28 | (defmethod copy-ir-node :around 29 | ((context (eql 'ir-eliminate-common-subexpressions)) 30 | (ir-node ir-node)) 31 | ;; Go to the outermost block that this call depends on. 32 | (let ((*blocks* (nthcdr (- *depth* (ir-node-depth ir-node)) *blocks*))) 33 | (call-next-method))) 34 | 35 | (defmethod copy-ir-node 36 | ((context (eql 'ir-eliminate-common-subexpressions)) 37 | (ir-call ir-call)) 38 | (let ((fnrecord (ir-call-fnrecord ir-call)) 39 | (inputs (ir-node-inputs ir-call)) 40 | (outputs (ir-node-outputs ir-call))) 41 | (when (typo:fnrecord-purep fnrecord) 42 | ;; Check whether an existing call node can be reused. 43 | (map-block-inner-nodes 44 | (lambda (node) 45 | (when (and (ir-call-p node) 46 | (eq (ir-call-fnrecord node) fnrecord) 47 | (if (eql outputs '*) 48 | (eql (ir-node-outputs node) '*) 49 | (= (length (ir-node-outputs node)) 50 | (length outputs))) 51 | (= (length (ir-node-inputs node)) 52 | (length inputs)) 53 | (loop for input in inputs 54 | for other-input in (ir-node-inputs node) 55 | always (eq (copy-ir-value context input) other-input))) 56 | (replace-node-outputs ir-call (ir-node-outputs node)) 57 | (return-from copy-ir-node node))) 58 | *initial-node*)) 59 | (call-next-method))) 60 | 61 | (defmethod copy-ir-node 62 | ((context (eql 'ir-eliminate-common-subexpressions)) 63 | (ir-construct ir-construct)) 64 | ;; Check whether there is an existing construct node that can be reused. 65 | (map-block-inner-nodes 66 | (lambda (node) 67 | (when (and (ir-construct-p node) 68 | (equal (ir-construct-form node) 69 | (ir-construct-form ir-construct))) 70 | (replace-node-outputs ir-construct (ir-node-outputs node)) 71 | (return-from copy-ir-node node))) 72 | *initial-node*) 73 | (call-next-method)) 74 | 75 | (defmethod ir-value-depth ((ir-value ir-value)) 76 | (let ((producer (ir-value-producer ir-value))) 77 | (if (ir-loop-p producer) 78 | (1+ (ir-node-depth producer)) 79 | (ir-node-depth producer)))) 80 | 81 | (defmethod ir-node-depth ((ir-initial-node ir-initial-node)) 82 | (do ((dominator (ir-node-dominator ir-initial-node) (ir-node-dominator dominator)) 83 | (depth 0 (1+ depth))) 84 | ((null dominator) depth))) 85 | 86 | (defmethod ir-node-depth ((ir-node ir-node)) 87 | (ir-node-depth (ir-initial-node ir-node))) 88 | 89 | (defmethod ir-node-depth ((ir-call ir-call)) 90 | (if (typo:fnrecord-purep (ir-call-fnrecord ir-call)) 91 | (reduce #'max (ir-node-inputs ir-call) 92 | :key #'ir-value-depth 93 | :initial-value 0) 94 | (call-next-method))) 95 | 96 | (defmethod ir-node-depth ((ir-construct ir-construct)) 97 | 0) 98 | -------------------------------------------------------------------------------- /code/ir/ir-expand.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | ;; A hash table, mapping from values to symbols. 4 | (defvar *ir-expand-value-names*) 5 | 6 | (defun value-name (value) 7 | (check-type value ir-value) 8 | (alexandria:ensure-gethash value *ir-expand-value-names* (gensym "V"))) 9 | 10 | (defgeneric ir-expand-node (ir-node)) 11 | 12 | (defun ir-expand (ir) 13 | (let ((*ir-expand-value-names* (make-hash-table :test #'eq)) 14 | (*gensym-counter* 0)) 15 | (ir-expand-node ir))) 16 | 17 | (defmethod ir-expand-node ((ir-initial-node ir-initial-node)) 18 | (let ((final-node (ir-final-node ir-initial-node))) 19 | `(basic-block 20 | ,@(loop for node = (ir-node-successor ir-initial-node) then (ir-node-successor node) 21 | until (eq node final-node) 22 | collect (ir-expand-node node))))) 23 | 24 | (defmethod ir-expand-node ((ir-loop ir-loop)) 25 | (with-accessors ((inputs ir-node-inputs) 26 | (variable ir-loop-variable) 27 | (body ir-loop-body) 28 | (test ir-loop-test)) ir-loop 29 | (destructuring-bind (start step) inputs 30 | (let ((variable (value-name variable)) 31 | (start (value-name start)) 32 | (step (value-name step))) 33 | `(() (loop for ,variable fixnum = ,start then (+ ,variable ,step) 34 | while ,(ir-expand-node test) 35 | do ,(ir-expand-node body))))))) 36 | 37 | (defmethod ir-expand-node ((ir-call ir-call)) 38 | (let* ((fnrecord (ir-call-fnrecord ir-call)) 39 | (outputs (ir-node-outputs ir-call))) 40 | `(,(if (eql outputs '*) '() (mapcar #'value-name outputs)) 41 | (the ,(ir-node-values-type ir-call) 42 | ,(let ((name (typo:fnrecord-name fnrecord)) 43 | (arguments (mapcar #'value-name (ir-node-inputs ir-call)))) 44 | (cond ((null name) 45 | `(funcall ,(typo:fnrecord-function fnrecord) ,@arguments)) 46 | ((symbolp name) 47 | `(,name ,@arguments)) 48 | (t 49 | `(funcall (function ,name) ,@arguments)))))))) 50 | 51 | (defmethod ir-expand-node ((ir-if ir-if)) 52 | `(,(mapcar #'value-name (ir-node-outputs ir-if)) 53 | (the ,(ir-node-values-type ir-if) 54 | (if ,(value-name (first (ir-node-inputs ir-if))) 55 | ,(ir-expand-node (ir-if-then ir-if)) 56 | ,(ir-expand-node (ir-if-else ir-if)))))) 57 | 58 | (defmethod ir-expand-node ((ir-construct ir-construct)) 59 | `(,(mapcar #'value-name (ir-node-outputs ir-construct)) 60 | (the ,(ir-node-values-type ir-construct) 61 | ,(ir-construct-form ir-construct)))) 62 | 63 | (defmethod ir-expand-node ((ir-enclose ir-enclose)) 64 | `(,(mapcar #'value-name (ir-node-outputs ir-enclose)) 65 | (the ,(ir-node-values-type ir-enclose) 66 | (lambda ,(mapcar #'value-name (ir-enclose-argument-values ir-enclose)) 67 | ,(ir-expand-node (ir-enclose-body ir-enclose)))))) 68 | 69 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 70 | ;;; 71 | ;;; The Basic Block Macro 72 | 73 | (defmacro basic-block (&rest body) 74 | (if (null body) 75 | `(values) 76 | (expand-basic-block body))) 77 | 78 | (defun expand-basic-block (body) 79 | (trivia:ematch body 80 | ((list (list (list* _) form)) 81 | form) 82 | ((list* (list (list) form) 83 | rest) 84 | `(progn ,form ,(expand-basic-block rest))) 85 | ((list* (list (list variable) form) 86 | rest) 87 | (expand-basic-block/let* (list (list variable form)) rest)) 88 | ((list* (list (list* variables) form) 89 | rest) 90 | `(multiple-value-bind ,variables ,form 91 | ,(expand-basic-block rest))) 92 | ((list* malformed _) 93 | (error "Malformed block component: ~S" malformed)))) 94 | 95 | (defun expand-basic-block/let* (reversed-bindings body) 96 | (trivia:ematch body 97 | ((list (list (list* _) form)) 98 | `(let* ,(reverse reversed-bindings) 99 | ,form)) 100 | ((list* (list (list) form) 101 | rest) 102 | `(let* ,(reverse reversed-bindings) 103 | ,form 104 | ,(expand-basic-block rest))) 105 | ((list* (list (list variable) form) rest) 106 | (expand-basic-block/let* (list* (list variable form) reversed-bindings) rest)) 107 | ((list* (list (list* variables) form) rest) 108 | `(let* ,(reverse reversed-bindings) 109 | (multiple-value-bind ,variables ,form 110 | ,(expand-basic-block rest)))) 111 | ((list* malformed _) 112 | (error "Malformed block component: ~S" malformed)))) 113 | -------------------------------------------------------------------------------- /code/ir/ir-isl-create-loopus-node.lisp: -------------------------------------------------------------------------------- 1 | (in-package :loopus.ir) 2 | 3 | ;; Takes a cl-isl node (for instance a loop node), and create a loopus nodes for it 4 | (defgeneric execute-node (node)) 5 | 6 | ;; Loop block 7 | (defmethod execute-node ((node isl:for-node)) 8 | (let* ((old-hashtable (alexandria:copy-hash-table *ir-value-copies*)) ; lexical scope 9 | (variable-isl (isl:for-node-get-iterator node)) 10 | (possible-loop-variables (append possible-loop-variables (list (isl:id-expr-get-id variable-isl)))) 11 | (start-value (isl:for-node-get-init node)) 12 | (test-ast (isl:for-node-get-cond node)) 13 | (increment (isl:for-node-get-inc node)) 14 | (body-ast (isl:for-node-get-body node)) 15 | ;; Generation of the nodes 16 | (start (execute-expr start-value)) 17 | (step (execute-expr increment)) 18 | (variable (create-loop-var variable-isl)) 19 | (loop (make-instance 'ir-node)) 20 | (body (make-ir-initial-and-ir-final-node loop)) 21 | (test (make-ir-initial-and-ir-final-node loop))) 22 | (let ((*blocks* (cons (ir-final-node test) *blocks*))) 23 | (execute-expr test-ast)) 24 | (let ((*depth-loop-variables* (cons variable *depth-loop-variables*)) 25 | (*current-depth* (1+ *current-depth*)) 26 | (*blocks* (cons (ir-final-node body) *blocks*))) 27 | (setf (gethash node *ir-value-copies*) variable) 28 | (execute-node body-ast)) 29 | (change-class loop 'ir-loop 30 | :variable variable 31 | :inputs (list start step) 32 | :test test 33 | :body body) 34 | ;; Restore state before we leave the loop 35 | (setf *ir-value-copies* old-hashtable) 36 | (delete-loop-var variable-isl) 37 | loop)) 38 | 39 | ;; A single statement 40 | (defmethod execute-node ((node isl:user-node)) 41 | (let* ((node (isl:user-node-get-expr node)) 42 | (how-many-args (isl:op-expr-get-n-arg node)) 43 | ;; We go 2 go because we have a counter between each loop variable in the domain 44 | ;; (The 1st one is empty, and we have a counter before/after each loop variable, hence the start at 2) 45 | (real-args (loop for i from 2 below how-many-args by 2 collect (execute-expr (isl:op-expr-get-op-arg node i)))) 46 | (counter-value (isl:value-object 47 | (isl:int-expr-get-value 48 | (isl:op-expr-get-op-arg node (1- how-many-args))))) 49 | (old-node (gethash counter-value *id-to-expression*)) 50 | (old-code (ir-node-inputs old-node)) 51 | ;; old-code is the arguments of the call 52 | ;; We now want to replace each argument by the new value from real-args! 53 | ;; todo check if what we do is correct 54 | (old-code (let* ((*depth-loop-variables* real-args)) 55 | (loop for e in old-code collect (copy-ir-node 'output e))))) 56 | (make-instance 'ir-call 57 | :fnrecord (ir-call-fnrecord old-node) 58 | :inputs old-code 59 | :outputs nil 60 | ;; Nil because we split each expression into subexpressions ? 61 | ;; doen't work with multiple return value ? 62 | ;; todo 63 | ))) 64 | 65 | ;; A block is a sequence of instructions 66 | ;; Todo lexical scope ? 67 | (defmethod execute-node ((node isl:block-node)) 68 | (mapcar #'execute-node 69 | (isl:ast-node-list-elements (isl:block-node-getlist node)))) 70 | 71 | ;; End of execute-node 72 | ;; Now some utilities 73 | 74 | ;; To copy loopus things 75 | ;; Todo rewrite them 76 | (defmethod copy-ir-node ((context (eql 'output)) (ir ir-value)) 77 | (copy-ir-value context ir)) 78 | 79 | (defmethod copy-ir-value ((context (eql 'output)) (ir-value ir-value) &optional (ntype (typo:universal-ntype))) 80 | (let ((d (gethash (ir-value-producer ir-value) *depth-node*))) 81 | (if d 82 | (nth d (reverse *depth-loop-variables*)) 83 | ;;(copy-ir-value nil ir-value) 84 | (let ((found (gethash ir-value *ir-value-copies*)) 85 | (res 86 | (let* ((declared-type (ir-value-declared-type ir-value)) 87 | (declared-ntype (typo:type-specifier-ntype declared-type)) 88 | (derived-ntype (ir-value-derived-ntype ir-value))) 89 | (values 90 | (alexandria:ensure-gethash 91 | ir-value 92 | *ir-value-copies* 93 | (make-instance 'ir-value 94 | :declared-type declared-type 95 | :derived-ntype 96 | (typo:ntype-intersection 97 | declared-ntype 98 | (typo:ntype-intersection derived-ntype ntype)))))))) 99 | (when (and (not found) (ir-construct-p (ir-value-producer ir-value))) 100 | (make-instance 'ir-construct 101 | :form (ir-construct-form (ir-value-producer ir-value)) 102 | :outputs (list res))) 103 | (when (and (not found) (ir-call-p (ir-value-producer ir-value))) 104 | (copy-ir-node context (ir-value-producer ir-value))) 105 | res) 106 | ;;(call-next-method) 107 | ))) 108 | 109 | -------------------------------------------------------------------------------- /code/ir/ir-specialize.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | (defun ir-specialize (ir) 4 | "Returns a copy of IR in which the derived type of each value is refined 5 | based on the knowledge about its producer, and where each function call 6 | has been replaced by the most specific function that has identical 7 | semantics but for the (possibly refined) type of its inputs." 8 | (let ((*ir-value-copies* (make-hash-table :test #'eq))) 9 | (copy-ir-block 'ir-specialize ir nil))) 10 | 11 | (defun find-specialized-value (ir-value) 12 | (multiple-value-bind (copy present-p) 13 | (gethash ir-value *ir-value-copies*) 14 | (if (not present-p) 15 | (error "Reference to IR value that hasn't been specialized upon yet: ~S" 16 | ir-value) 17 | copy))) 18 | 19 | (defmethod copy-ir-node 20 | ((context (eql 'ir-specialize)) 21 | (ir-call ir-call)) 22 | (let* ((outputs (ir-node-outputs ir-call)) 23 | (n-outputs (if (eql outputs '*) '* (length (ir-node-outputs ir-call)))) 24 | (max-typed-outputs (if (integerp n-outputs) n-outputs (1- multiple-values-limit)))) 25 | ;; Wrappers can be either IR nodes or IR values. 26 | (labels ((make-value (ntype) 27 | (make-instance 'ir-value 28 | :derived-ntype ntype)) 29 | (wrapper-nth-value-ntype (n wrapper) 30 | (etypecase wrapper 31 | (ir-value (if (zerop n) 32 | (ir-value-derived-ntype wrapper) 33 | (typo:type-specifier-ntype 'null))) 34 | (ir-call 35 | (let ((outputs (ir-node-outputs wrapper))) 36 | (if (< n (length outputs)) 37 | (ir-value-derived-ntype (nth n outputs)) 38 | (typo:type-specifier-ntype 'null)))))) 39 | (wrap-constant (constant) 40 | (let ((ir-value (make-value (typo:ntype-of constant)))) 41 | (make-instance 'ir-construct 42 | :form `',constant 43 | :outputs (list ir-value)) 44 | ir-value)) 45 | (wrapper-outputs (wrapper expected-values) 46 | (if (eql expected-values '*) 47 | '* 48 | (let ((outputs 49 | (etypecase wrapper 50 | (ir-value (list wrapper)) 51 | (ir-node (ir-node-outputs wrapper))))) 52 | (if (<= expected-values (length outputs)) 53 | (subseq outputs 0 expected-values) 54 | (let ((default (make-value (typo:ntype-of nil)))) 55 | (make-instance 'ir-construct 56 | :form 'nil 57 | :outputs (list default)) 58 | (replace (make-list expected-values :initial-element default) 59 | outputs)))))) 60 | (wrap-function (fnrecord wrappers mandatory optional rest) 61 | (make-instance 'ir-call 62 | :fnrecord fnrecord 63 | :inputs 64 | (loop for wrapper in wrappers 65 | collect (first (wrapper-outputs wrapper 1))) 66 | :outputs 67 | (let ((index 0)) 68 | (flet () 69 | (append 70 | (loop for ntype in mandatory 71 | do (incf index) 72 | collect (make-value ntype)) 73 | (loop for ntype in optional 74 | do (incf index) 75 | collect (make-value (typo:ntype-union ntype (typo:type-specifier-ntype 'null)))) 76 | (unless (eql outputs '*) 77 | (loop while (< index max-typed-outputs) 78 | for ntype = (typo:ntype-union rest (typo:type-specifier-ntype 'null)) 79 | do (incf index) 80 | collect (make-value ntype))))))))) 81 | (let ((wrapper 82 | (typo:specialize 83 | (ir-call-fnrecord ir-call) 84 | (mapcar #'find-specialized-value (ir-node-inputs ir-call)) 85 | :wrap-constant #'wrap-constant 86 | :wrap-function #'wrap-function 87 | :wrapper-nth-value-ntype #'wrapper-nth-value-ntype))) 88 | (replace-node-outputs ir-call (wrapper-outputs wrapper n-outputs)))))) 89 | 90 | (defmethod copy-ir-node 91 | ((context (eql 'ir-specialize)) 92 | (ir-if ir-if)) 93 | (let* ((node (make-instance 'ir-node)) 94 | (then (copy-ir-block context (ir-if-then ir-if) node)) 95 | (else (copy-ir-block context (ir-if-else ir-if) node)) 96 | (node-outputs (ir-node-outputs ir-if)) 97 | (then-outputs (ir-node-outputs (ir-node-predecessor (ir-final-node then)))) 98 | (else-outputs (ir-node-outputs (ir-node-predecessor (ir-final-node then))))) 99 | (change-class node 'ir-if 100 | :then then 101 | :else else 102 | :inputs (list (find-specialized-value (first (ir-node-inputs ir-if)))) 103 | :outputs 104 | (if (eql node-outputs '*) 105 | '* 106 | (loop for output in node-outputs 107 | collect 108 | (copy-ir-value 109 | nil 110 | output 111 | (typo:ntype-union 112 | (if (null then-outputs) 113 | (typo:universal-ntype) 114 | (ir-value-derived-ntype (pop then-outputs))) 115 | (if (null else-outputs) 116 | (typo:universal-ntype) 117 | (ir-value-derived-ntype (pop else-outputs)))))))))) 118 | 119 | (defmethod copy-ir-node 120 | ((context (eql 'ir-specialize)) 121 | (ir-loop ir-loop)) 122 | (let* ((loop (call-next-method)) 123 | (test (ir-loop-test loop)) 124 | (last-node (ir-node-predecessor (ir-final-node test)))) 125 | (setf (slot-value last-node '%outputs) '*))) 126 | -------------------------------------------------------------------------------- /code/ir/ir-isl-optimize.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | ;; Some function to compute properties about the loop, and then isl-optimize 4 | 5 | ;; Max dimension of array access on read/write access (print array) doesn't count 6 | ;; We don't use it anymore because everything is row-major-aref, so the max dimension we want is 1 7 | ;; To keep in case we switch back to supporting aref 8 | (defgeneric compute-max-array-dimension (ir)) 9 | (defmethod compute-max-array-dimension ((ir ir-loop)) 10 | (compute-max-array-dimension (ir-loop-body ir))) 11 | (defmethod compute-max-array-dimension ((ir ir-if)) 12 | (max 13 | (compute-max-array-dimension (ir-if-else ir)) 14 | (compute-max-array-dimension (ir-if-else ir)))) 15 | ;; todo refactor this and the update-node on ir-call in input.lisp 16 | (defmethod compute-max-array-dimension ((ir ir-call)) 17 | (let ((args (ir-node-inputs ir)) 18 | (is-aref (eql 'aref (typo:fnrecord-name (ir-call-fnrecord ir)))) 19 | (is-setf (equal '(setf aref) (typo:fnrecord-name (ir-call-fnrecord ir))))) 20 | (cond 21 | ;; args is either (aref array idx...) or ((setf aref) value array idx...) 22 | (is-aref (length (cdr args))) ; it's (aref array idx1 idx2 ...) 23 | (is-setf (length (cddr args))) ; it's ((setf aref) value array idx1 idx2), hence cddr 24 | (t 0)))) 25 | (defmethod compute-max-array-dimension ((ir ir-initial-node)) 26 | (let ((value 0)) 27 | (map-block-inner-nodes 28 | (lambda (ir) (setf value (max value (compute-max-array-dimension ir)))) 29 | ir) 30 | value)) 31 | (defmethod compute-max-array-dimension ((ir ir-node)) 0) 32 | 33 | ;; Max number of free variable 34 | (defgeneric compute-max-free-variable (ir)) 35 | (defmethod compute-max-free-variable ((ir ir-loop)) 36 | (compute-max-free-variable (ir-loop-body ir))) 37 | (defmethod compute-max-free-variable ((ir ir-if)) 38 | (+ (compute-map-free-variable (ir-if-else ir)) 39 | (compute-map-free-variable (ir-if-else ir)))) 40 | (defmethod compute-max-free-variable ((ir ir-initial-node)) 41 | (let ((value 0)) 42 | (map-block-inner-nodes 43 | (lambda (ir) (setf value (+ value (compute-max-free-variable ir)))) 44 | ir) 45 | value)) 46 | ;; For now, we create a free variable unless it's a integer or a function 47 | ;; Todo either better counting, or creating them on the fly 48 | (defmethod compute-max-free-variable ((ir ir-construct)) 49 | (let* ((ntype (ir-value-derived-ntype (first (ir-node-outputs ir))))) 50 | (if (and (typo:eql-ntype-p ntype) 51 | (or 52 | (integerp (typo:eql-ntype-object ntype)) 53 | (functionp (typo:eql-ntype-object ntype)))) 54 | 0 1))) 55 | (defmethod compute-max-free-variable ((ir ir-node)) 0) 56 | 57 | 58 | ;; This code setf a lot of variables 59 | ;; Each of them have a quick comment of "what it does" 60 | ;; This commment is next to the "defparameter" of the variable 61 | (defun ir-isl-optimize (ir) 62 | "Returns a copy of IR where it's reordered by isl" 63 | 64 | ;; First, allocate the memory 65 | (let* ((*size-domain* (1+ (* 2 (compute-max-loop-depth ir)))) 66 | ;;(ins *size-domain*) 67 | (*space-domain* (isl:create-space-set 0 *size-domain*)) 68 | (*size-range* 2) ;; (1+ (compute-max-array-dimension ir))) 69 | ;;(ins *size-range*) 70 | (*space-range* (isl:create-space-set 0 *size-range*)) 71 | (*space-map-domain-range* (isl:create-space-map 0 *size-domain* *size-range*)) 72 | (*space-map-schedule* (isl:create-space-map 0 *size-domain* *size-domain*)) 73 | (*size-free-parameters* (compute-max-free-variable ir)) 74 | ;;(ins *size-free-parameters*) 75 | ;; Add parameters from free variables 76 | (*free-variable-to-index* (make-hash-table :test 'equal))) 77 | (loop for i below *size-free-parameters* do 78 | (let ((id (isl:make-gensym-identifier 'fv))) 79 | (setf (gethash (symbol-name (isl:identifier-name id)) *free-variable-to-index*) i) 80 | (setf *space-domain* (isl:space-add-param-id *space-domain* id)) 81 | (setf *space-range* (isl:space-add-param-id *space-range* id)) 82 | (setf *space-map-domain-range* (isl:space-add-param-id *space-map-domain-range* id)) 83 | (setf *space-map-schedule* (isl:space-add-param-id *space-map-schedule* id)))) 84 | (let* ((*construct-to-identifier* nil) 85 | (position-next-free-variable nil) 86 | (*set-domain* (isl:union-set-empty *space-domain*)) 87 | (*map-read* (isl:union-map-empty *space-map-domain-range*)) 88 | (*map-write* (isl:union-map-empty *space-map-domain-range*)) 89 | (*map-schedule* (isl:union-map-empty *space-map-schedule*)) 90 | ;; End of allocation of memory 91 | 92 | ;; Special parameters - first phase 93 | (*construct-to-identifier* (make-hash-table)) 94 | (position-next-free-variable -1) ; -1 because we use the return value of incf, so the first use returns 0 95 | (*counter-range* 0) 96 | (*all-irnodes* (make-hash-table)) 97 | (*loop-variables* '()) 98 | (*loop-bounds* '()) 99 | (*counter-domain* '()) 100 | (*global-counter* 0) 101 | (*id-to-expression* (make-hash-table)) 102 | (*depth-node* (make-hash-table)) 103 | (*current-depth* 0) 104 | (*node-to-read* (make-hash-table)) 105 | (*node-to-write* (make-hash-table)) 106 | (*set-of-side-effect* (isl:union-set-from-str "{ [0] }"))) 107 | ;; End of setf special parameters 108 | ;; First phase 109 | (map-block-inner-nodes #'update-node ir) 110 | (print "Domain, read, write, and schedule:") 111 | (print *set-domain*) 112 | (print *map-read*) 113 | (print *map-write*) 114 | (print *map-schedule*) 115 | ;; End of first phase 116 | (let* ((node nil) 117 | (*ir-value-copies* (make-hash-table)) 118 | (possible-loop-variables nil) 119 | (*id-to-nodes* (make-hash-table :test 'equal)) 120 | (*depth-loop-variables* '()) 121 | (*current-depth* 0) 122 | (*position-to-loopusvariable* (make-hash-table))) 123 | (maphash (lambda (key value) (setf (gethash value *position-to-loopusvariable*) key)) *construct-to-identifier*) 124 | ;; End of setf special parameters - Begin of second phase 125 | (let ((init-node (isl::generate-debug-ast *set-domain* *map-read* *map-write* *map-schedule*)) 126 | (node (isl:generate-optimized-ast *set-domain* *map-read* *map-write* *map-schedule*))) 127 | (isl:pretty-print-node init-node) 128 | (isl:pretty-print-node node) 129 | (print "ok") 130 | (let ((r (my-main node nil))) 131 | (print (ir-expand r)) 132 | r)))))) 133 | 134 | ;; (defun ir-isl-optimize (ir) ir) 135 | 136 | ;; utilities - to remove 137 | (defun ins (e) 138 | (break "Inspect ~a" e)) 139 | (defun ins2 (&rest rest) 140 | (break "Inspect ~a" rest)) 141 | -------------------------------------------------------------------------------- /code/test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :loopus.ir) 2 | 3 | (declaim (optimize (debug 3))) 4 | 5 | (macrolet ((acc (v) `(setf (aref accumulator 0) (+ (aref accumulator 0) ,v)))) 6 | (let* ((dim 10) 7 | (v-start 2) 8 | (v-end 5) 9 | ;; Single loop over arrays 10 | (1d (make-array dim)) 11 | (2d (make-array (list dim dim))) 12 | (2dd (make-array (list dim dim))) 13 | (3d (make-array (list dim dim dim))) 14 | ;(4d (make-array (list dim dim dim dim))) 15 | ;; Matrix multiplication 16 | (dim-C-x 5) 17 | (dim-C-y 5) 18 | (dim-temp 5) 19 | ;; C = A * B 20 | ;; A has dim (x, temp) and B (temp, y) 21 | (matrix-A (make-array (list dim-C-x dim-temp))) 22 | (matrix-B (make-array (list dim-temp dim-C-y))) 23 | (matrix-C (make-array (list dim-C-x dim-C-y))) 24 | (matrix-C-check (make-array (list dim-C-x dim-C-y))) 25 | ;; Various variables 26 | (accumulator (make-array 1))) ; todo later variable to 1d array to 27 | 28 | 29 | ;;(loop i (loop j (aref i i))) -> memory proximity is weird (same for j) 30 | ;;the first variable is the most outer loop 31 | ;; With this memory it's working fine 32 | ;;(memory-proximity (union-map-from-str "{ [0, i1, 0, i3, -1, -1, -1, -1] -> [0, 1 + i1, 0, i3, -1, -1, -1, -1] : 0 <= i1 <= 8 and 0 <= i3 <= 9 }")) 33 | 34 | 35 | ;; Doesnt work when it's { [0, i1, 0, i3, -1, -1, -1, -1] -> [0, 1 + i1, 0, o3, -1, -1, -1, -1] : 0 <= i1 <= 8 and 0 <= i3 <= 9 and 0 <= o3 <= 9 }> 36 | ;; Which is the correct thing, and should still reorder :( 37 | ;; todo 38 | 39 | ;; Index which are an operation 40 | #+or(progn 41 | (print "1d") 42 | (print 1d) 43 | (loopus:for (i 0 9) 44 | ;(setf (aref 1d i #+or(/ 2 (+ 1 i))) i) 45 | (loopus:for (j 0 10) 46 | (setf (aref 2d i j) j)) 47 | (loopus:for (k 0 10) 48 | (setf (aref 2d i k) k))) 49 | ;; todo when we use j here, the error is weird (hard to understand we use a non-defined variable) 50 | (print 1d)) 51 | 52 | 53 | ;; Sum over arrays 54 | ;; 1D 55 | #+or(progn 56 | (print "1d") 57 | (print 1d) 58 | (loopus:for (i 2 v-end) ;; doesn't work anymore with v-start because of step 59 | (setf (row-major-aref 1d i) 2)) 60 | (print 1d) 61 | 62 | ;; Doesn't get reordered. Nice 63 | (loopus:for (i 0 2) 64 | (loopus:for (j 0 2) 65 | (print (+ (* 10 j) i)))) 66 | 67 | ;;(setf (aref accumulator 0) 1) 68 | #+or(loopus:for (i 0 10) 69 | (acc (aref 1d i))) 70 | (print 1d) 71 | (print accumulator)) 72 | 73 | ;; 2D 74 | ;; aref not taking into accoutn? 75 | #+or(progn 76 | (print "2d") 77 | (loop for i below 10 do 78 | (loop for j below 10 do 79 | (setf (aref 2d i j) 0))) 80 | (loop for i from 2 below 9 do 81 | (loop for j from 1 below i by 2 do 82 | (setf (aref 2d j i) (+ i j)))) 83 | (print 2d) 84 | (loop for i below 10 do 85 | (loop for j below 10 do 86 | (setf (aref 2d i j) 0))) 87 | ;; todo 88 | ;; if step is not known, the loop direction is unknown, and not sure what I should do 89 | ;; but the user probably know the loop direction anyway, maybe better to ask him 90 | (loopus:for (i 0 10) 91 | (loopus:for (j 0 10) 92 | ;;(format t "~a ~%" (+ (* 10 i) j)) 93 | (setf (row-major-aref 2d (+ (* 10 i) j)) (+ i j))) 94 | #+or(loopus:for (j 1 i) 95 | (setf (aref 2dfefef i j) (+ i j)))) 96 | #+or(loopus:for (i 2 9) 97 | (loopus:for (j 1 i) 98 | (setf (row-major-aref 2d (+ (* j (array-dimension 2d 1)) i)) 99 | (+ i j)))) 100 | (print 2d) 101 | #+or(loopus:for (i 5 10) 102 | (loopus:for (j 5 10) 103 | ;;(acc (aref 2d i j)))) 104 | ;;(setf (aref 2d i j) 1) 105 | ;;(setf (aref 2d j i) 1) 106 | (SETF (AREF ACCUMULATOR 0) (+ (aref accumulator 0) (AREF |2D| i j))) 107 | )) 108 | #+or(loopus:for (j 0 10) 109 | (loopus:for (i 0 5) 110 | ;;(acc (aref 2d i j)))) 111 | (SETF (AREF ACCUMULATOR 0) (+ (AREF ACCUMULATOR 0) (AREF |2D| I J))))) 112 | 113 | ;; Doesnt work because WaW dependancies 114 | 115 | (print accumulator)) 116 | ;; todo - reverse on ast generation for proximity 117 | ;; 3D 118 | #+or(progn 119 | (print "3d") 120 | (loopus:for (i 0 10) 121 | (loopus:for (j 0 10) 122 | (loopus:for (k 0 10) 123 | (setf (aref 3d i j k) (+ i j k))))) 124 | #+or(loopus:for (i 0 10) 125 | (loopus:for (j 0 10) 126 | (loopus:for (k 0 10) 127 | (acc (aref 3d i j k))))) 128 | (print 3d) 129 | (print accumulator)) 130 | 131 | ;; Matrix multiplication 132 | #+or(progn 133 | ;; Init 134 | #+or(loopus:for (i 0 5) 135 | (loopus:for (j 0 5) 136 | (setf (aref matrix-A i j) (random 10)) 137 | (setf (aref matrix-B i j) (random 10)) 138 | (setf (aref matrix-C i j) 0) 139 | (setf (aref matrix-C-check i j) 0))) 140 | (loop for i below 5 do 141 | (loop for j below 5 do 142 | (setf (aref matrix-A i j) (random 10)) 143 | (setf (aref matrix-B i j) (random 10)) 144 | (setf (aref matrix-C i j) 0) 145 | (setf (aref matrix-C-check i j) 0))) 146 | ;; Mul 147 | (time 148 | (loopus:for (k 0 5) 149 | (loopus:for (j 0 5) 150 | (loopus:for (i 0 5) 151 | (setf (aref matrix-C i j) 152 | (+ (aref matrix-C i j) 153 | (* (aref matrix-A i k) 154 | (aref matrix-B k j)))))))) 155 | (time 156 | (loop for i below 4 do 157 | (loop for j below 4 do 158 | (loop for k below 4 do 159 | (setf (aref matrix-C-check i j) 160 | (+ (aref matrix-C-check i j) 161 | (* (aref matrix-A i k) 162 | (aref matrix-B k j)))))))) 163 | (print matrix-A) 164 | (print matrix-B) 165 | (print matrix-C) 166 | (print matrix-C-check)) 167 | 168 | ;; Loop over triangles 169 | ;; Todo 170 | 171 | ;; End 172 | )) 173 | 174 | #| 175 | ;; Test of expressions that aren't a read/write 176 | (progn 177 | (defun mm (arg) (1+ arg)) 178 | (let ((2d (make-array '(2 2)))) 179 | (loop for i below 2 do (loop for j below 2 do (setf (aref 2d i j) (+ i (* 10 j))))) 180 | (loop for i below 2 do 181 | (loop for j below 2 do 182 | (print (aref 2d j i)))) 183 | (print "--") 184 | (loopus:for (i 0 2) 185 | (loopus:for (j 0 2) 186 | (aref 2d j i))) 187 | (loopus:for (i 0 2) 188 | (loopus:for (j 0 2) 189 | (aref 2d j i) 190 | (aref 2d j i)))) 191 | (loopus:for (i 0 10) (print (mm i))) 192 | (loopus:for (i 0 10) 193 | (print i) 194 | (print 2) 195 | (loopus:for (i 0 2) 196 | (loopus:for (j 0 2) 197 | (print (+ 1 2 3 4 5)) 198 | (row-major-aref 2d (+ (* i 2) j)))))) 199 | 200 | |# 201 | 202 | 203 | (defun print3 (a b) 204 | (setf a b)) 205 | 206 | #+or(progn 207 | (defun mm (arg) (1+ arg)) 208 | (let ((2d (make-array '(10 10))) 209 | (ss 1)) 210 | #+or(loop for i from 0 below 10 do 211 | (loop for j from 0 below 10 do 212 | (setf (row-major-aref 2d (+ (* j 10) i)) 213 | (+ j (* 10 i))))) 214 | (loopus:for (i 0 10) 215 | (loopus:for (j 0 10) 216 | (setf (row-major-aref 2d (+ (* j 10) i)) 217 | (+ j (* 10 i))))) 218 | ;; (loop for i below 10 do (loop for j below 10 do (setf (aref 2d i j) (+ i (* 10 j))))) 219 | (loop for i from 0 below 10 do 220 | (loop for j from 0 below 10 do 221 | (print (aref 2d j i)))) 222 | (print "--"))) 223 | 224 | 225 | #+or(let ((start 2) 226 | (end 10) 227 | (step 2) 228 | (2d (make-array '(10 10)))) 229 | (declare (array 2d)) 230 | (loopus:for (i start end) 231 | (loopus:for (j 0 i) 232 | (print (row-major-aref 2d (+ (* 10 i) j)))))) 233 | 234 | 235 | 236 | ;; todo fix where we read/write in memory in map read 237 | 238 | 239 | 240 | 241 | 242 | ;; memory locality 243 | ;; (?) step not integerp 244 | ;; todo turn this into a cl isl 245 | ;; export every list object of cl isl by hand 246 | ;; fix the or/and by creating a if in loopus ast 247 | ;; create a cl isl ast when i give it to cl isl 248 | 249 | 250 | 251 | 252 | 253 | 254 | 255 | 256 | 257 | (loopus:for (i 0 5) (print i)) 258 | -------------------------------------------------------------------------------- /code/math/polynomial.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.math) 2 | 3 | ;;; Variables 4 | 5 | (defvar *default-polynomial-representation* 'expanded-polynomial) 6 | 7 | ;;; Generic Functions 8 | 9 | (defgeneric polynomialp (x)) 10 | 11 | (defgeneric one-arg-polynomial- (p)) 12 | 13 | (defgeneric two-arg-polynomial+ (p1 p2)) 14 | 15 | (defgeneric two-arg-polynomial* (p1 p2)) 16 | 17 | (defgeneric polynomial-expression (p)) 18 | 19 | (defgeneric coerce-to-polynomial (x representation)) 20 | 21 | ;;; Classes 22 | 23 | (defclass polynomial () 24 | ()) 25 | 26 | ;;; Methods 27 | 28 | (defmethod print-object ((polynomial polynomial) stream) 29 | (print-unreadable-object (polynomial stream :type t :identity nil) 30 | (write (expression-from-polynomial polynomial) :stream stream))) 31 | 32 | (defmethod polynomialp ((object t)) nil) 33 | 34 | (defmethod polynomialp ((polynomial polynomial)) t) 35 | 36 | (defmethod two-arg-polynomial+ ((p1 polynomial) (p2 polynomial)) 37 | (if (eq (class-of p1) (class-of p2)) 38 | (call-next-method) 39 | (two-arg-polynomial+ p1 (coerce-to-polynomial p2 p1)))) 40 | 41 | (defmethod two-arg-polynomial* ((p1 polynomial) (p2 polynomial)) 42 | (if (eq (class-of p1) (class-of p2)) 43 | (call-next-method) 44 | (two-arg-polynomial* p1 (coerce-to-polynomial p2 p1)))) 45 | 46 | (defmethod coerce-to-polynomial ((x t) (representation symbol)) 47 | (let ((class (find-class representation nil))) 48 | (if (not class) 49 | (call-next-method) 50 | (coerce-to-polynomial x (class-prototype class))))) 51 | 52 | (defmethod coerce-to-polynomial ((expression list) (representation polynomial)) 53 | (polynomial-from-expression expression)) 54 | 55 | (defmethod coerce-to-polynomial ((x polynomial) (prototype polynomial)) 56 | (if (typep x (class-of prototype)) 57 | x 58 | (call-next-method))) 59 | 60 | (defmethod coerce-to-polynomial :around ((x t) (prototype polynomial)) 61 | (let ((result (call-next-method))) 62 | (unless (typep result (class-of prototype)) 63 | (error "Returned a ~A where a ~A was expected. This is a bug." 64 | (class-name (class-of result)) 65 | (class-name (class-of prototype)))) 66 | result)) 67 | 68 | ;;; Functions 69 | 70 | (defun polynomial (object &optional (representation nil representation-supplied-p)) 71 | (if (not representation-supplied-p) 72 | (if (polynomialp object) 73 | object 74 | (coerce-to-polynomial object *default-polynomial-representation*)) 75 | (coerce-to-polynomial object representation))) 76 | 77 | (defun polynomial- (polynomial &rest more-polynomials) 78 | (if (null more-polynomials) 79 | (one-arg-polynomial- polynomial) 80 | (reduce #'two-arg-polynomial+ 81 | more-polynomials 82 | :key #'one-arg-polynomial- 83 | :initial-value polynomial))) 84 | 85 | (defun polynomial+ (&rest polynomials) 86 | (case (length polynomials) 87 | (0 (polynomial 0)) 88 | (1 (polynomial (first polynomials))) 89 | (otherwise 90 | (reduce #'two-arg-polynomial+ polynomials)))) 91 | 92 | (defun polynomial* (&rest polynomials) 93 | (case (length polynomials) 94 | (0 (polynomial 1)) 95 | (1 (polynomial (first polynomials))) 96 | (otherwise 97 | (reduce #'two-arg-polynomial* polynomials)))) 98 | 99 | (defun polynomial-from-expression 100 | (expression &key (environment '()) (representation *default-polynomial-representation*)) 101 | (labels ((lookup (symbol) 102 | (let ((entry (assoc symbol environment))) 103 | (if (consp entry) 104 | (cdr entry) 105 | (let ((variable (make-instance 'variable :name symbol))) 106 | (push (cons symbol variable) environment) 107 | variable)))) 108 | (convert (x) 109 | (if (atom x) 110 | (if (symbolp x) 111 | (coerce-to-polynomial (lookup x) representation) 112 | (coerce-to-polynomial x representation)) 113 | (let ((operator (first x)) 114 | (arguments (mapcar #'convert (rest x)))) 115 | (case operator 116 | (+ (apply #'polynomial+ arguments)) 117 | (- (apply #'polynomial- arguments)) 118 | (* (apply #'polynomial* arguments)) 119 | (otherwise 120 | (error "Cannot convert calls to ~A into a polynomial." 121 | operator))))))) 122 | (convert expression))) 123 | 124 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 125 | ;;; 126 | ;;; Expanded Polynomial 127 | ;;; 128 | ;;; Each expanded polynomial is represented as a list of addends. Each 129 | ;;; added is a list of the form (C V1 ... VN), where C is an integer and 130 | ;;; where V1 to VN are (possibly duplicate) variables. The value of an 131 | ;;; addend is computed by multiplying the integer C and the values of each 132 | ;;; variable V1 to VN. The value of the entire polynomial is computed by 133 | ;;; summing up the values of each addend. 134 | ;;; 135 | ;;; By convention, each addend must have a nonzero first entry, and all 136 | ;;; variables must be sorted by their number such that variables with a 137 | ;;; lower number come first. Furthermore, no two addends of an expanded 138 | ;;; polynomial must have the same list of variables, and all addends must 139 | ;;; be sorted such that for any two addends, the one a lower number in the 140 | ;;; first differing variable comes first. 141 | 142 | (defclass expanded-polynomial (polynomial) 143 | ((%addends 144 | :initarg :addends 145 | :initform (alexandria:required-argument :addends) 146 | :type list 147 | :reader expanded-polynomial-addends))) 148 | 149 | (defun make-addend (constant variables) 150 | (list* constant variables)) 151 | 152 | (defun addend-constant (addend) 153 | (the integer (first addend))) 154 | 155 | (defun addend-variables (addend) 156 | (the list (rest addend))) 157 | 158 | (defun canonicalize-addend (addend) 159 | (let ((constant (addend-constant addend)) 160 | (variables (addend-variables addend))) 161 | (if (loop for (v1 v2) on variables 162 | until (not v2) 163 | always (<= (variable-number v1) 164 | (variable-number v2))) 165 | addend 166 | (make-addend constant (sort (copy-list variables) #'<= :key #'variable-number))))) 167 | 168 | (defun addend<= (a1 a2) 169 | (let ((a1-variables (addend-variables a1)) 170 | (a2-variables (addend-variables a2))) 171 | (loop 172 | (when (null a1-variables) (return t)) 173 | (when (null a2-variables) (return nil)) 174 | (let ((v1 (pop a1-variables)) 175 | (v2 (pop a2-variables))) 176 | (unless (eq v1 v2) 177 | (unless (<= (variable-number v1) 178 | (variable-number v2)) 179 | (return nil))))))) 180 | 181 | (defun canonicalize-addends (addends) 182 | (let ((result '()) 183 | (previous nil)) 184 | (loop for addend in (sort (mapcar #'canonicalize-addend addends) #'addend<=) do 185 | (cond ((not previous) 186 | (setf previous addend)) 187 | ((equal (addend-variables previous) 188 | (addend-variables addend)) 189 | (setf previous 190 | `(,(+ (addend-constant previous) 191 | (addend-constant addend)) 192 | ,@(addend-variables previous)))) 193 | (t 194 | (unless (zerop (addend-constant previous)) 195 | (push previous result)) 196 | (setf previous addend)))) 197 | (unless (or (not previous) 198 | (zerop (addend-constant previous))) 199 | (push previous result)) 200 | result)) 201 | 202 | (defmethod two-arg-polynomial+ 203 | ((p1 expanded-polynomial) 204 | (p2 expanded-polynomial)) 205 | (make-instance 'expanded-polynomial 206 | :addends 207 | (canonicalize-addends 208 | (append (expanded-polynomial-addends p1) 209 | (expanded-polynomial-addends p2))))) 210 | 211 | (defmethod one-arg-polynomial- 212 | ((p expanded-polynomial)) 213 | (make-instance 'expanded-polynomial 214 | :addends 215 | (loop for addend in (expanded-polynomial-addends p) 216 | collect 217 | (make-addend (- (addend-constant addend)) 218 | (addend-variables addend))))) 219 | 220 | (defmethod two-arg-polynomial* 221 | ((p1 expanded-polynomial) 222 | (p2 expanded-polynomial)) 223 | (make-instance 'expanded-polynomial 224 | :addends 225 | (let ((addends '())) 226 | (loop for a1 in (expanded-polynomial-addends p1) do 227 | (loop for a2 in (expanded-polynomial-addends p2) do 228 | (push (make-addend (* (addend-constant a1) 229 | (addend-constant a2)) 230 | (append (addend-variables a1) 231 | (addend-variables a2))) 232 | addends))) 233 | (canonicalize-addends addends)))) 234 | 235 | (defmethod coerce-to-polynomial 236 | ((integer integer) 237 | (prototype expanded-polynomial)) 238 | (make-instance 'expanded-polynomial 239 | :addends (if (zerop integer) 240 | (list) 241 | (list (make-addend integer '()))))) 242 | 243 | (defmethod coerce-to-polynomial 244 | ((variable variable) 245 | (prototype expanded-polynomial)) 246 | (make-instance 'expanded-polynomial 247 | :addends (list (make-addend 1 (list variable))))) 248 | 249 | (defmethod expression-from-polynomial 250 | ((p expanded-polynomial)) 251 | (expression-from-addends (expanded-polynomial-addends p))) 252 | 253 | (defun expression-from-addends (addends) 254 | (cond ((null addends) 255 | 0) 256 | ((null (rest addends)) 257 | (expression-from-addend (first addends))) 258 | (t 259 | `(+ ,@(mapcar #'expression-from-addend addends))))) 260 | 261 | (defun expression-from-addend (addend) 262 | (let ((constant (addend-constant addend)) 263 | (variables (addend-variables addend))) 264 | (cond ((zerop constant) 265 | 0) 266 | ((null variables) 267 | constant) 268 | ((and (null (cdr variables)) 269 | (= constant 1)) 270 | (expression-from-variable (first variables))) 271 | ((= constant 1) 272 | `(* ,@(mapcar #'expression-from-variable variables))) 273 | (t 274 | `(* ,constant ,@(mapcar #'expression-from-variable variables)))))) 275 | -------------------------------------------------------------------------------- /code/ir/ir-convert.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | ;;; This file contains the machinery for converting a loop nest to Loopus 4 | ;;; IR. This is essentially a variation of EVAL for a very limited subset 5 | ;;; of Common Lisp, except that it doesn't actually compute a result but 6 | ;;; assemble IR nodes. 7 | 8 | ;;; Hash tables for caching IR constructs. 9 | (defvar *ir-convert-constants*) 10 | (defvar *ir-convert-variables*) 11 | (defvar *ir-convert-function-names*) 12 | 13 | (defun ir-convert-in-environment (form env &optional (expected-values '*)) 14 | (multiple-value-bind (initial-node final-node) 15 | (make-ir-initial-and-ir-final-node nil) 16 | (let ((*ir-convert-constants* (make-hash-table :test #'eql)) 17 | (*ir-convert-variables* (make-hash-table :test #'eq)) 18 | (*ir-convert-function-names* (make-hash-table :test #'equal)) 19 | (*blocks* (cons final-node *blocks*))) 20 | (ir-convert 21 | ;; TODO It would be better not to use macroexpand-all, but to expand 22 | ;; things ourselves. Otherwise we risk that an implementation expands 23 | ;; macros in a way that relies on internals we can't handle. 24 | (trivial-macroexpand-all:macroexpand-all 25 | ;; Each occurrence of the FOR macro is turned into a call to the 26 | ;; function %FOR. This function is not defined, but handled specially 27 | ;; by the IR conversion process. 28 | `(macrolet ((for ((variable start end &optional (step 1)) &body body) 29 | `(%for ',variable ,start ,end ,step (locally ,@body)))) 30 | ,form) 31 | env) 32 | (make-lexenv env) 33 | expected-values) 34 | (values initial-node final-node)))) 35 | 36 | (defgeneric ir-convert-symbol (symbol lexenv expected-values)) 37 | 38 | (defgeneric ir-convert-compound-form (operator rest lexenv expected-values)) 39 | 40 | (defmacro ensure-expected-values 41 | (expected-values &body body) 42 | (alexandria:once-only (expected-values) 43 | (alexandria:with-gensyms (thunk values) 44 | `(let ((,thunk (lambda () ,@body))) 45 | (case expected-values 46 | ((*) (funcall ,thunk)) 47 | ((1) (let ((value (funcall ,thunk))) 48 | (assert (ir-value-p value)) 49 | (values value))) 50 | (otherwise 51 | (let ((,values (multiple-value-list (funcall ,thunk)))) 52 | (assert (every #'ir-value-p ,values)) 53 | (values-list 54 | (loop repeat ,expected-values 55 | collect 56 | (cond ((null ,values) 57 | (ir-convert-constant nil)) 58 | ((consp ,values) 59 | (pop ,values)))))))))))) 60 | 61 | (defun make-outputs (expected-values) 62 | (if (eq expected-values '*) 63 | '* 64 | (loop repeat expected-values collect (make-instance 'ir-value)))) 65 | 66 | (defun output-values-list (outputs) 67 | (if (eql outputs '*) 68 | (values) 69 | (values-list outputs))) 70 | 71 | (defun ir-convert (form lexenv &optional (expected-values 1)) 72 | (ensure-expected-values expected-values 73 | (if (atom form) 74 | (if (symbolp form) 75 | (ir-convert-symbol form lexenv expected-values) 76 | (ir-convert-constant form)) 77 | (ir-convert-compound-form (first form) (rest form) lexenv expected-values)))) 78 | 79 | ;;; Conversion of Constants 80 | 81 | (defun ir-convert-constant (constant) 82 | (values 83 | (alexandria:ensure-gethash 84 | constant 85 | *ir-convert-constants* 86 | (let* ((*blocks* (last *blocks*)) 87 | (value (make-instance 'ir-value :declared-type `(eql ,constant)))) 88 | (make-instance 'ir-construct 89 | :form `',constant 90 | :outputs (list value)) 91 | value)))) 92 | 93 | (defun ir-convert-variable (variable-name &optional (declared-type t)) 94 | (values 95 | (alexandria:ensure-gethash 96 | variable-name 97 | *ir-convert-variables* 98 | (let* ((*blocks* (last *blocks*)) 99 | (value (make-instance 'ir-value :declared-type declared-type))) 100 | (make-instance 'ir-construct 101 | :form variable-name 102 | :outputs (list value)) 103 | value)))) 104 | 105 | (defun ir-convert-function (function-name) 106 | (values 107 | (alexandria:ensure-gethash 108 | function-name 109 | *ir-convert-function-names* 110 | (let* ((*blocks* (last *blocks*)) 111 | (value (make-instance 'ir-value 112 | :declared-type 'function 113 | :derived-ntype 114 | (if (fboundp function-name) 115 | (typo:ntype-of (fdefinition function-name)) 116 | (typo:type-specifier-ntype 'function))))) 117 | (make-instance 'ir-construct 118 | :form `(function ,function-name) 119 | :outputs (list value)) 120 | value)))) 121 | 122 | ;;; Conversion of Symbols 123 | 124 | (defmethod ir-convert-symbol ((variable-name symbol) lexenv expected-values) 125 | ;; We might want to need this once we can handle macroexpansion (and, in 126 | ;; particular, symbol macroexpansion) ourselves. 127 | (declare (ignore expected-values)) 128 | (let* ((env (lexenv-parent lexenv)) 129 | (vrecords (lexenv-vrecords lexenv)) 130 | (vrecord (find variable-name vrecords :key #'vrecord-name))) 131 | (if (not (null vrecord)) 132 | (vrecord-value vrecord) 133 | (multiple-value-bind (kind localp alist) 134 | (trivial-cltl2:variable-information variable-name env) 135 | (declare (ignore localp)) 136 | (case kind 137 | (:special 138 | (error "Cannot (yet) handle special variables.")) 139 | ((:lexical :global :constant) 140 | (if (constantp variable-name) 141 | (ir-convert-constant (eval variable-name)) 142 | (ir-convert-variable 143 | variable-name 144 | `(and ,@(loop for (key . value) in alist 145 | when (eq key 'type) 146 | collect value))))) 147 | (t 148 | (ir-convert-variable variable-name))))))) 149 | 150 | (defun map-declaration-specifiers (function declarations) 151 | (dolist (declaration declarations) 152 | (trivia:match declaration 153 | ((list* 'declare declaration-specifiers) 154 | (dolist (declaration-specifier declaration-specifiers) 155 | (funcall function declaration-specifier))) 156 | (_ (error "Malformed declaration: ~S" declaration))))) 157 | 158 | (defparameter *declaration-identifiers* 159 | '(dynamic-extent ignore optimize 160 | ftype inline special 161 | ignorable notinline type)) 162 | 163 | (defun map-type-declarations (function declarations) 164 | (map-declaration-specifiers 165 | (lambda (declaration-specifier) 166 | (trivia:match declaration-specifier 167 | ((list* 'type type-specifier variables) 168 | (dolist (variable variables) 169 | (funcall function variable type-specifier))) 170 | ((list* type-specifier variables) 171 | (when (member type-specifier *declaration-identifiers*) 172 | (trivia.fail:fail)) 173 | (dolist (variable variables) 174 | (funcall function variable type-specifier))))) 175 | declarations)) 176 | 177 | (defun handle-type-declarations (declarations lexenv) 178 | (map-type-declarations 179 | (lambda (variable type) 180 | (ir-value-declare-type (ir-convert variable lexenv) type)) 181 | declarations)) 182 | 183 | ;;; Conversion of Compound Forms 184 | 185 | (defmethod ir-convert-compound-form 186 | ((operator symbol) rest lexenv expected-values) 187 | (ir-convert `(funcall (function ,operator) ,@rest) lexenv expected-values)) 188 | 189 | (defmethod ir-convert-compound-form 190 | ((_ (eql 'funcall)) rest lexenv expected-values) 191 | (let ((outputs (make-outputs expected-values))) 192 | (make-instance 'ir-call 193 | :fnrecord (typo:ensure-fnrecord 'funcall) 194 | :inputs (mapcar (lambda (form) (ir-convert form lexenv)) rest) 195 | :outputs outputs) 196 | (output-values-list outputs))) 197 | 198 | (defmethod ir-convert-compound-form 199 | ((_ (eql 'macrolet)) rest lexenv expected-values) 200 | ;; We have already processed everything with MACROEXPAND-ALL, so we can 201 | ;; just convert the macrolet's body. 202 | (ir-convert `(locally ,@(rest rest)) lexenv expected-values)) 203 | 204 | (defmethod ir-convert-compound-form 205 | ((_ (eql 'function)) rest lexenv expected-values) 206 | (trivia:match rest 207 | ((list (and function-name (type function-name))) 208 | (let* ((env (lexenv-parent lexenv)) 209 | (frecords (lexenv-frecords lexenv)) 210 | (frecord (find function-name frecords :key #'frecord-name :test #'equal))) 211 | (if (not (null frecord)) 212 | (frecord-value frecord) 213 | (multiple-value-bind (kind localp alist) 214 | (trivial-cltl2:function-information function-name env) 215 | (declare (ignore localp alist)) 216 | (case kind 217 | (:special-form 218 | (error "Invalid reference to the special form ~S." 219 | function-name)) 220 | (:function 221 | (ir-convert-function function-name)) 222 | (t 223 | (let ((value (make-instance 'ir-value :declared-type 'function))) 224 | (make-instance 'ir-construct 225 | :form `(function ,function-name) 226 | :outputs (list value)) 227 | value))))))) 228 | ((list (list* 'lambda (list* lambda-list) body)) 229 | (when (intersection lambda-list lambda-list-keywords) 230 | (error "Lambda list keywords aren't supported, yet.")) 231 | (multiple-value-bind (forms declarations) (alexandria:parse-body body) 232 | (let* ((value (make-instance 'ir-value)) 233 | (arguments 234 | (loop repeat (length lambda-list) 235 | collect (make-instance 'ir-value))) 236 | (lexenv 237 | (augment-lexenv 238 | lexenv 239 | (loop for variable in lambda-list 240 | for value in arguments 241 | collect (make-vrecord variable value)) 242 | '())) 243 | (ir-enclose (make-instance 'ir-node)) 244 | (body-node (make-ir-initial-and-ir-final-node ir-enclose))) 245 | (handle-type-declarations declarations lexenv) 246 | ;; Convert the body. 247 | (let ((*blocks* (cons (ir-final-node body-node) *blocks*))) 248 | (ir-convert `(locally ,@forms) lexenv '*)) 249 | (change-class ir-enclose 'ir-enclose 250 | :outputs (list value) 251 | :arguments arguments 252 | :body body-node) 253 | value))) 254 | (_ (error "Malformed function special form :~S." 255 | `(function ,@rest))))) 256 | 257 | (defmethod ir-convert-compound-form 258 | ((_ (eql 'progn)) rest lexenv expected-values) 259 | (ir-convert-progn rest lexenv expected-values)) 260 | 261 | (defun ir-convert-progn (forms lexenv expected-values) 262 | (dolist (form (butlast forms)) 263 | (ir-convert form lexenv 0)) 264 | (ir-convert (first (last forms)) lexenv expected-values)) 265 | 266 | (defmethod ir-convert-compound-form 267 | ((_ (eql 'locally)) rest lexenv expected-values) 268 | (multiple-value-bind (body-forms declarations) 269 | (alexandria:parse-body rest) 270 | (handle-type-declarations declarations lexenv) 271 | (ir-convert-progn body-forms lexenv expected-values))) 272 | 273 | (defmethod ir-convert-compound-form 274 | ((_ (eql 'let)) rest lexenv expected-values) 275 | (unless (and (consp rest) (listp (first rest))) 276 | (error "Malformed let form: ~S" `(let ,@rest))) 277 | (multiple-value-bind (forms declarations) 278 | (alexandria:parse-body (rest rest)) 279 | (let ((lexenv 280 | (augment-lexenv 281 | lexenv 282 | (loop for (name form) in (mapcar #'canonicalize-binding (first rest)) 283 | collect 284 | (make-vrecord name (ir-convert form lexenv))) 285 | '()))) 286 | (handle-type-declarations declarations lexenv) 287 | (ir-convert-progn forms lexenv expected-values)))) 288 | 289 | (defmethod ir-convert-compound-form 290 | ((_ (eql 'let*)) rest lexenv expected-values) 291 | (unless (and (consp rest) (listp (first rest))) 292 | (error "Malformed let* form: ~S" `(let* ,@rest))) 293 | (loop for (name form) in (mapcar #'canonicalize-binding (first rest)) do 294 | (setf lexenv 295 | (augment-lexenv 296 | lexenv 297 | (list (make-vrecord name (ir-convert form lexenv))) 298 | '()))) 299 | (multiple-value-bind (forms declarations) 300 | (alexandria:parse-body (rest rest)) 301 | (handle-type-declarations declarations lexenv) 302 | (ir-convert-progn forms lexenv expected-values))) 303 | 304 | (defun canonicalize-binding (binding) 305 | (trivia:match binding 306 | ((type variable-name) 307 | (list binding nil)) 308 | ((list (and name (type variable-name)) form) 309 | (list name form)) 310 | (_ (error "Malformed binding: ~S" binding)))) 311 | 312 | (defmethod ir-convert-compound-form 313 | ((_ (eql 'flet)) rest lexenv expected-values) 314 | (unless (and (consp rest) 315 | (listp (first rest))) 316 | (error "Malformed flet form: ~S" `(flet ,@rest))) 317 | (let ((lexenv 318 | (augment-lexenv 319 | lexenv 320 | '() 321 | (loop for definition in (first rest) 322 | collect 323 | (trivia:match definition 324 | ((list* (and function-name (type function-name)) (list* lambda-list) body) 325 | (make-frecord 326 | function-name 327 | (ir-convert `(function (lambda ,lambda-list ,@body)) lexenv))) 328 | (_ (error "Malformed flet definition: ~S" 329 | definition))))))) 330 | (multiple-value-bind (forms declarations) 331 | (alexandria:parse-body (rest rest)) 332 | (handle-type-declarations declarations lexenv) 333 | (ir-convert-progn forms lexenv expected-values)))) 334 | 335 | (defmethod ir-convert-compound-form 336 | ((_ (eql 'the)) rest lexenv expected-values) 337 | (unless (= 2 (length rest)) 338 | (error "Malformed the form: ~S" `(the ,@rest))) 339 | (multiple-value-bind (required optional rest restp) 340 | (parse-values-type-specifier (first rest)) 341 | (let* ((values (multiple-value-list (ir-convert (second rest) lexenv expected-values))) 342 | (rest values)) 343 | (loop for type in required while values do 344 | (ir-value-declare-type (pop rest) type)) 345 | (loop for type in optional while values do 346 | (ir-value-declare-type (pop rest) `(or ,type null))) 347 | (when restp 348 | (loop while values do 349 | (ir-value-declare-type (pop rest) rest))) 350 | (output-values-list values)))) 351 | 352 | (defun parse-values-type-specifier (type-specifier) 353 | (trivia:match type-specifier 354 | ((list* 'values rest) 355 | (let ((required '()) 356 | (optional '()) 357 | (rest-type nil) 358 | (rest-type-p nil)) 359 | (labels ((fail () 360 | (error "Invalid values type specifier: ~S" 361 | type-specifier)) 362 | (process-required (rest) 363 | (unless (null rest) 364 | (let ((first (first rest)) 365 | (rest (rest rest))) 366 | (case first 367 | (&rest (process-rest rest)) 368 | (&optional (process-optional rest)) 369 | (otherwise 370 | (push first required) 371 | (process-required rest)))))) 372 | (process-optional (rest) 373 | (unless (null rest) 374 | (let ((first (first rest)) 375 | (rest (rest rest))) 376 | (case first 377 | (&rest (process-rest rest)) 378 | (&optional (fail)) 379 | (otherwise 380 | (push first optional) 381 | (process-optional rest)))))) 382 | (process-rest (rest) 383 | (when (null rest) (fail)) 384 | (let ((first (first rest)) 385 | (rest (rest rest))) 386 | (unless (null rest) (fail)) 387 | (case first 388 | (&rest (fail)) 389 | (&optional (fail)) 390 | (otherwise 391 | (setf rest-type-p t) 392 | (setf rest-type first)))))) 393 | (process-required rest) 394 | (values (reverse required) 395 | (reverse optional) 396 | rest-type 397 | rest-type-p)))) 398 | (_ (values (list type-specifier) '() nil nil)))) 399 | 400 | (defmethod ir-convert-compound-form 401 | ((_ (eql 'if)) rest lexenv expected-values) 402 | (unless (<= 2 (length rest) 3) 403 | (error "Malformed IF form: ~S" `(if ,@rest))) 404 | (destructuring-bind (test then &optional else) rest 405 | (let* ((test-value (ir-convert test lexenv)) 406 | (ir-if (make-instance 'ir-node)) 407 | (then-node (make-ir-initial-and-ir-final-node ir-if)) 408 | (else-node (make-ir-initial-and-ir-final-node ir-if)) 409 | (outputs (make-outputs expected-values))) 410 | (let ((*blocks* (cons (ir-final-node then-node) *blocks*))) 411 | (ir-convert then lexenv expected-values)) 412 | (let ((*blocks* (cons (ir-final-node else-node) *blocks*))) 413 | (ir-convert else lexenv expected-values)) 414 | (change-class ir-if 'ir-if 415 | :inputs (list test-value) 416 | :outputs outputs 417 | :then then-node 418 | :else else-node) 419 | (output-values-list outputs)))) 420 | 421 | (defmethod ir-convert-compound-form 422 | ((_ (eql '%for)) rest lexenv expected-values) 423 | (declare (ignore expected-values)) ; Loops return nothing. 424 | (destructuring-bind (quoted-variable-name start end step body-form) rest 425 | (let* ((variable-name (second quoted-variable-name)) 426 | (variable (make-instance 'ir-value)) 427 | (ir-loop (make-instance 'ir-node-with-outputs :outputs (list variable))) 428 | (body (make-ir-initial-and-ir-final-node ir-loop)) 429 | (test (make-ir-initial-and-ir-final-node ir-loop)) 430 | (start-value (ir-convert start lexenv)) 431 | (end-value (ir-convert end lexenv)) 432 | (step-value (ir-convert step lexenv))) 433 | (ir-value-declare-type variable 'fixnum) 434 | (let* ((end-sym (gensym)) 435 | (step-sym (gensym)) 436 | (lexenv (augment-lexenv lexenv (list (make-vrecord step-sym step-value) 437 | (make-vrecord end-sym end-value) 438 | (make-vrecord variable-name variable)) '())) 439 | (*blocks* (cons (ir-final-node test) *blocks*))) 440 | (ir-convert `(if (minusp ,step-sym) 441 | (> ,variable-name ,end-sym) 442 | (< ,variable-name ,end-sym)) 443 | lexenv '*)) 444 | (let ((lexenv (augment-lexenv lexenv (list (make-vrecord variable-name variable)) '())) 445 | (*blocks* (cons (ir-final-node body) *blocks*))) 446 | (ir-convert body-form lexenv 0)) 447 | (change-class ir-loop 'ir-loop 448 | :inputs (list start-value step-value) 449 | :variable variable 450 | :body body 451 | :test test) 452 | (values)))) 453 | 454 | (defmethod ir-convert-compound-form 455 | ((_ (eql 'quote)) rest lexenv expected-values) 456 | (unless (= 1 (length rest)) 457 | (error "Malformed QUOTE form: ~S" `',@rest)) 458 | (ir-convert-constant (first rest))) 459 | -------------------------------------------------------------------------------- /code/ir/ir.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:loopus.ir) 2 | 3 | ;;; The Loopus IR, consists of a sequence of nodes that are connected via 4 | ;;; their successor and predecessor slot. Each such chain of nodes starts 5 | ;;; with an initial node and ends with a final node. When control is 6 | ;;; transferred to a node, it reads its (possibly empty) list of input 7 | ;;; values, computes its output values and transfers control to its 8 | ;;; successor. The node that precedes the final node returns its outputs 9 | ;;; as multiple values. Some nodes, such as IR-IF, IR-ENCLOSE, and 10 | ;;; IR-LOOP, have a reference to one or more other initial nodes that are 11 | ;;; processed specially. 12 | 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | ;;; 15 | ;;; Special Variables 16 | 17 | ;; A list of all surrounding final nodes, sorted by dominance, starting 18 | ;; with the innermost surrounding block. 19 | (defvar *blocks* '()) 20 | 21 | (define-symbol-macro *final-node* (first *blocks*)) 22 | 23 | (define-symbol-macro *initial-node* (ir-initial-node *final-node*)) 24 | 25 | ;;; A hash table, mapping from IR values to their copy. 26 | (defvar *ir-value-copies*) 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;;; 30 | ;;; Generic Functions 31 | 32 | (defgeneric ir-node-p (object) (:method ((object t)) nil)) 33 | 34 | (defgeneric ir-node-dominator (ir-node)) 35 | 36 | (defgeneric ir-node-inputs (ir-node)) 37 | 38 | (defgeneric ir-node-outputs (ir-node)) 39 | 40 | (defgeneric ir-node-successor (ir-node)) 41 | 42 | (defgeneric ir-node-predecessor (ir-node)) 43 | 44 | (defgeneric ir-node-values-type (ir-node)) 45 | 46 | 47 | (defgeneric ir-initial-node (ir-node)) 48 | 49 | (defgeneric ir-initial-node-p (object) (:method ((object t)) nil)) 50 | 51 | (defgeneric ir-final-node (ir-node)) 52 | 53 | (defgeneric ir-final-node-p (object) (:method ((object t)) nil)) 54 | 55 | (defgeneric make-ir-initial-and-ir-final-node (dominator)) 56 | 57 | 58 | (defgeneric ir-loop-p (object) (:method ((object t)) nil)) 59 | 60 | (defgeneric ir-loop-variable (ir-loop)) 61 | 62 | (defgeneric ir-loop-test (ir-loop)) 63 | 64 | (defgeneric ir-loop-body (ir-loop)) 65 | 66 | 67 | (defgeneric ir-call-p (object) (:method ((object t)) nil)) 68 | 69 | (defgeneric ir-call-fnrecord (ir-call)) 70 | 71 | 72 | (defgeneric ir-if-p (object) (:method ((object t)) nil)) 73 | 74 | (defgeneric ir-if-then (ir-if)) 75 | 76 | (defgeneric ir-if-else (ir-if)) 77 | 78 | 79 | (defgeneric ir-construct-p (object) (:method ((object t)) nil)) 80 | 81 | (defgeneric ir-construct-form (ir-construct)) 82 | 83 | 84 | (defgeneric ir-enclose-p (object) (:method ((object t)) nil)) 85 | 86 | (defgeneric ir-enclose-argument-values (ir-enclose)) 87 | 88 | (defgeneric ir-enclose-body (ir-enclose)) 89 | 90 | 91 | (defgeneric ir-value-p (object) (:method ((object t)) nil)) 92 | 93 | (defgeneric ir-value-producer (ir-value)) 94 | 95 | (defgeneric ir-value-users (ir-value)) 96 | 97 | (defgeneric ir-value-declared-type (ir-value)) 98 | 99 | (defgeneric ir-value-derived-ntype (ir-value)) 100 | 101 | (defgeneric ir-value-declare-type (ir-value type-specifier)) 102 | 103 | 104 | (defgeneric map-block-inner-nodes (function ir-node)) 105 | 106 | (defgeneric compute-max-loop-depth (ir)) 107 | 108 | (defgeneric insert-ir-node-before (ir-node future-successor)) 109 | 110 | (defgeneric insert-ir-node-after (ir-node future-predecessor)) 111 | 112 | (defgeneric extract-ir-node (ir-node)) 113 | 114 | (defgeneric copy-ir-value (context ir-value &optional ntype)) 115 | 116 | (defgeneric copy-ir-node (context ir-node)) 117 | 118 | (defgeneric copy-ir-block (context ir-node dominator)) 119 | 120 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 121 | ;;; 122 | ;;; Classes 123 | 124 | (defclass ir-node () 125 | ()) 126 | 127 | (defclass ir-value () 128 | ((%declared-type 129 | :initarg :declared-type 130 | :initform 't 131 | :reader ir-value-declared-type) 132 | (%derived-ntype 133 | :initarg :derived-ntype 134 | :initform (typo:universal-ntype) 135 | :type typo:ntype 136 | :reader ir-value-derived-ntype) 137 | (%producer 138 | :type ir-node 139 | :reader ir-value-producer) 140 | (%users 141 | :initform '() 142 | :reader ir-value-users))) 143 | 144 | (defmethod print-object ((ir-value ir-value) stream) 145 | (print-unreadable-object (ir-value stream :type t) 146 | (let ((t1 (ir-value-declared-type ir-value)) 147 | (t2 (typo:ntype-type-specifier (ir-value-derived-ntype ir-value)))) 148 | (format stream "~S" (if (subtypep t2 t1) t2 t1))))) 149 | 150 | (defun ensure-ir-value-producer (ir-value producer) 151 | (if (slot-boundp ir-value '%producer) 152 | (let ((other-producer (slot-value ir-value '%producer))) 153 | (unless (eq producer other-producer) 154 | (error "Attempt to redefine the producer of ~S from ~S to ~S." 155 | ir-value other-producer producer))) 156 | (setf (slot-value ir-value '%producer) producer))) 157 | 158 | (defun ensure-ir-value-user (ir-value user) 159 | (pushnew user (slot-value ir-value '%users))) 160 | 161 | (defmethod ir-value-declare-type ((ir-value ir-value) new-type) 162 | (let ((old-type (ir-value-declared-type ir-value))) 163 | (cond ((subtypep old-type new-type) 164 | (values)) 165 | ((subtypep new-type old-type) 166 | (setf (slot-value ir-value '%declared-type) 167 | new-type)) 168 | ((subtypep `(and ,new-type ,old-type) nil) 169 | (error "Incompatible declared types ~S and ~S." 170 | new-type old-type)) 171 | (t 172 | (setf (slot-value ir-value '%declared-type) 173 | `(and ,new-type ,old-type)))) 174 | ir-value)) 175 | 176 | (defclass ir-node-with-dominator (ir-node) 177 | (;; The IR node 'above' this one, i.e., the unique loop or if node that 178 | ;; has a reference to this node, or some predecessor of this node. 179 | (%dominator 180 | :initarg :dominator 181 | :initform (alexandria:required-argument :dominator) 182 | :type (or null ir-node) 183 | :reader ir-node-dominator))) 184 | 185 | (defclass ir-node-with-inputs (ir-node) 186 | (;; The list of values that are used by this node. 187 | (%inputs 188 | :initarg :inputs 189 | :initform (alexandria:required-argument :inputs) 190 | :type list 191 | :reader ir-node-inputs))) 192 | 193 | (defmethod shared-initialize :after 194 | ((ir-node-with-inputs ir-node-with-inputs) slot-names &key &allow-other-keys) 195 | (declare (ignore slot-names)) 196 | (dolist (input (ir-node-inputs ir-node-with-inputs)) 197 | (ensure-ir-value-user input ir-node-with-inputs))) 198 | 199 | (defclass ir-node-with-outputs (ir-node) 200 | (;; The list of values that are produced by this node, or, if the node 201 | ;; occurs as the final node of a block in a context where the number of 202 | ;; expected values is not known, the symbol *. 203 | (%outputs 204 | :initarg :outputs 205 | :initform (alexandria:required-argument :outputs) 206 | :type (or list (eql *)) 207 | :reader ir-node-outputs))) 208 | 209 | (defmethod shared-initialize :after 210 | ((ir-node-with-outputs ir-node-with-outputs) slot-names &key &allow-other-keys) 211 | (declare (ignore slot-names)) 212 | (let ((outputs (ir-node-outputs ir-node-with-outputs))) 213 | (unless (eql outputs '*) 214 | (dolist (output outputs) 215 | (ensure-ir-value-producer output ir-node-with-outputs))))) 216 | 217 | (defclass ir-node-with-successor (ir-node) 218 | (;; The IR node that this node transfers control to. 219 | (%successor 220 | :initarg :successor 221 | :initform *final-node* 222 | :type ir-node 223 | :reader ir-node-successor 224 | :writer (setf ir-node-%successor)))) 225 | 226 | (defclass ir-node-with-predecessor (ir-node) 227 | (;; The IR node that this node receives control form. 228 | (%predecessor 229 | :initarg :predecessor 230 | :initform (ir-node-predecessor *final-node*) 231 | :type ir-node 232 | :reader ir-node-predecessor 233 | :writer (setf ir-node-%predecessor)))) 234 | 235 | (defclass ir-initial-node (ir-node-with-dominator ir-node-with-successor) 236 | (;; Each initial node has a reference to its corresponding final node. 237 | (%final-node 238 | :initarg :final-node 239 | :type ir-final-node 240 | :reader ir-final-node))) 241 | 242 | (defclass ir-final-node (ir-node-with-predecessor) 243 | (;; Each final node has a reference to its corresponding initial node. 244 | (%initial-node 245 | :initarg :initial-node 246 | :type ir-node 247 | :reader ir-initial-node))) 248 | 249 | (defclass ir-inner-node (ir-node-with-predecessor ir-node-with-successor) 250 | ()) 251 | 252 | (defmethod shared-initialize :after 253 | ((inner-node ir-inner-node) slot-names &key &allow-other-keys) 254 | (when (or (eql slot-names t) 255 | (and (member '%predecessor slot-names) 256 | (member '%successor slot-names))) 257 | (insert-ir-node-before inner-node *final-node*))) 258 | 259 | ;;; A loop node is an inner node with two inputs (start and step), zero 260 | ;;; outputs, the initial node of its body, and the initial node of a block 261 | ;;; that test whether the loop should continue. When control is 262 | ;;; transferred to the loop node, and as long as its test is true, it 263 | ;;; evaluates its body in an environment where the loop variable is bound 264 | ;;; to successive elements of the iteration space. 265 | (defclass ir-loop (ir-inner-node ir-node-with-inputs) 266 | ((%variable 267 | :initarg :variable 268 | :initform (alexandria:required-argument :variable) 269 | :type ir-value 270 | :reader ir-loop-variable) 271 | (%test 272 | :initarg :test 273 | :initform (alexandria:required-argument :test) 274 | :type ir-initial-node 275 | :reader ir-loop-test) 276 | (%body 277 | :initarg :body 278 | :initform (alexandria:required-argument :body) 279 | :type ir-initial-node 280 | :reader ir-loop-body))) 281 | 282 | (defmethod shared-initialize :after 283 | ((ir-loop ir-loop) slot-names &key &allow-other-keys) 284 | (ensure-ir-value-producer (ir-loop-variable ir-loop) ir-loop)) 285 | 286 | ;;; A call node is defined by an fnrecord that denotes a function, and 287 | ;;; further inputs that serve as the arguments of that function. It has 288 | ;;; some number of outputs (whose number need not fit to the number of 289 | ;;; values produced by the function). When control is transferred to it, 290 | ;;; it binds each output to the corresponding value obtained by invoking 291 | ;;; the function on the arguments. Outputs with no corresponding value are 292 | ;;; bound to NIL. 293 | (defclass ir-call (ir-inner-node ir-node-with-inputs ir-node-with-outputs) 294 | ((%fnrecord 295 | :initarg :fnrecord 296 | :initform nil 297 | :type (or typo:fnrecord null) 298 | :reader ir-call-fnrecord))) 299 | 300 | ;;; An if node is an inner node with one input that is the generalized 301 | ;;; boolean to test, some number of outputs, a reference to the initial 302 | ;;; node of its then part, and a reference to the initial node of its else 303 | ;;; part. When control is transferred to it, it transfers control to its 304 | ;;; then initial node if the input is true, and to its else initial node if 305 | ;;; the input is false. Then it binds its outputs to the values produced 306 | ;;; by whatever chain of nodes was chosen. 307 | (defclass ir-if (ir-inner-node ir-node-with-inputs ir-node-with-outputs) 308 | ((%then 309 | :initarg :then 310 | :initform (alexandria:required-argument :then) 311 | :type list 312 | :reader ir-if-then) 313 | (%else 314 | :initarg :else 315 | :initform (alexandria:required-argument :else) 316 | :type list 317 | :reader ir-if-else))) 318 | 319 | ;;; A construct node is an inner node with no inputs and some number of 320 | ;;; outputs. When control is transferred to it, it binds each output to 321 | ;;; the corresponding value obtained by evaluating its form. 322 | ;;; 323 | ;;; Construct nodes are used to handle constants, or references to 324 | ;;; functions or variables from outside of the loop nest. 325 | (defclass ir-construct (ir-inner-node ir-node-with-outputs) 326 | ((%form 327 | :initarg :form 328 | :initform (alexandria:required-argument :form) 329 | :reader ir-construct-form))) 330 | 331 | ;;; An enclose node is an inner node that has no inputs, and a single 332 | ;;; output that is the closure with the given arguments and body. 333 | (defclass ir-enclose (ir-inner-node) 334 | ((%inputs :initform '() :type null) 335 | ;; A list of IR values that are bound on each invocation of that 336 | ;; function. 337 | (%argument-values 338 | :initarg :argument-values 339 | :initform (alexandria:required-argument :argument-values) 340 | :type list 341 | :reader ir-enclose-argument-values) 342 | (%body 343 | :initarg :body 344 | :initform (alexandria:required-argument :body) 345 | :reader ir-enclose-body))) 346 | 347 | (defmethod shared-initialize :after 348 | ((ir-enclose ir-enclose) slot-names &key &allow-other-keys) 349 | (declare (ignore slot-names)) 350 | (dolist (argument-value (ir-enclose-argument-values ir-enclose)) 351 | (ensure-ir-value-producer argument-value ir-enclose))) 352 | 353 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 354 | ;;; 355 | ;;; Methods 356 | 357 | (defmethod ir-node-p ((ir-node ir-node)) 358 | t) 359 | 360 | (defmethod ir-node-dominator ((ir-node-with-predecessor ir-node-with-predecessor)) 361 | ;; Only the initial node has a direct reference to its dominator. All 362 | ;; other nodes have to follow their chain of predecessors. 363 | (ir-node-dominator (ir-node-predecessor ir-node-with-predecessor))) 364 | 365 | (defmethod ir-node-dominator ((ir-final-node ir-final-node)) 366 | ;; The final node doesn't have to chase the chain of predecessors, 367 | ;; because it has a direct reference to the initial node. 368 | (ir-node-dominator (ir-initial-node ir-final-node))) 369 | 370 | (defmethod ir-node-inputs ((ir-node ir-node)) 371 | '()) 372 | 373 | (defmethod ir-node-outputs ((ir-node ir-node)) 374 | '()) 375 | 376 | (defmethod ir-initial-node ((ir-initial-node ir-initial-node)) 377 | ir-initial-node) 378 | 379 | (defmethod ir-initial-node ((ir-node-with-predecessor ir-node-with-predecessor)) 380 | ;; Follow the chain of predecessors. 381 | (ir-initial-node (ir-node-predecessor ir-node-with-predecessor))) 382 | 383 | (defmethod ir-initial-node-p ((ir-initial-node ir-initial-node)) 384 | t) 385 | 386 | (defmethod ir-final-node ((ir-final-node ir-final-node)) 387 | ir-final-node) 388 | 389 | (defmethod ir-final-node ((ir-node-with-successor ir-node-with-successor)) 390 | ;; Follow the chain of successors. 391 | (ir-final-node (ir-node-successor ir-node-with-successor))) 392 | 393 | (defmethod ir-final-node-p ((ir-final-node ir-final-node)) 394 | t) 395 | 396 | (defmethod make-ir-initial-and-ir-final-node (dominator) 397 | (let ((initial-node (make-instance 'ir-node)) 398 | (final-node (make-instance 'ir-node))) 399 | (change-class final-node 'ir-final-node 400 | :initial-node initial-node 401 | :predecessor initial-node) 402 | (change-class initial-node 'ir-initial-node 403 | :dominator dominator 404 | :successor final-node 405 | :final-node final-node) 406 | (values initial-node final-node))) 407 | 408 | (defmethod ir-loop-p ((ir-loop ir-loop)) 409 | t) 410 | 411 | (defmethod ir-call-p ((ir-call ir-call)) 412 | t) 413 | 414 | (defmethod ir-if-p ((ir-if ir-if)) 415 | t) 416 | 417 | (defmethod ir-construct-p ((ir-construct ir-construct)) 418 | t) 419 | 420 | (defmethod ir-enclose-p ((ir-enclose ir-enclose)) 421 | t) 422 | 423 | (defmethod ir-value-p ((ir-value ir-value)) 424 | t) 425 | 426 | (defmethod ir-node-values-type ((ir-node ir-node)) 427 | '(values)) 428 | 429 | (defmethod ir-node-values-type ((ir-node-with-outputs ir-node-with-outputs)) 430 | (let ((outputs (ir-node-outputs ir-node-with-outputs))) 431 | (if (eql outputs '*) 432 | '(values) 433 | `(values ,@(mapcar #'ir-value-declared-type outputs))))) 434 | 435 | (defmethod ir-value-derived-type (ir-value) 436 | (typo:ntype-type-specifier 437 | (ir-value-derived-ntype ir-value))) 438 | 439 | (defmethod map-block-inner-nodes (function (ir-node ir-node)) 440 | (map-block-inner-nodes function (ir-initial-node ir-node))) 441 | 442 | (defmethod map-block-inner-nodes (function (initial-node ir-initial-node)) 443 | (let ((final-node (ir-final-node initial-node))) 444 | (loop for node = (ir-node-successor initial-node) 445 | then (ir-node-successor node) 446 | until (eq node final-node) do 447 | (funcall function node)))) 448 | 449 | (defmethod compute-max-loop-depth ((ir ir-loop)) 450 | (1+ 451 | (max (compute-max-loop-depth (ir-loop-test ir)) 452 | (compute-max-loop-depth (ir-loop-body ir))))) 453 | 454 | (defmethod compute-max-loop-depth ((ir ir-if)) 455 | (max 456 | (compute-max-loop-depth (ir-if-else ir)) 457 | (compute-max-loop-depth (ir-if-else ir)))) 458 | 459 | (defmethod compute-max-loop-depth ((ir ir-initial-node)) 460 | (let ((value 0)) 461 | (map-block-inner-nodes 462 | (lambda (ir) (setf value (max value (compute-max-loop-depth ir)))) 463 | ir) 464 | value)) 465 | 466 | (defmethod compute-max-loop-depth ((ir ir-node)) 0) 467 | 468 | (defmethod insert-ir-node-before 469 | ((ir-node ir-inner-node) 470 | (future-successor ir-node-with-predecessor)) 471 | (let ((a (ir-node-predecessor future-successor)) 472 | (b ir-node) 473 | (c future-successor)) 474 | (setf (ir-node-%successor b) c) 475 | (setf (ir-node-%predecessor b) a) 476 | (setf (ir-node-%successor a) b) 477 | (setf (ir-node-%predecessor c) b)) 478 | ir-node) 479 | 480 | (defmethod insert-ir-node-after 481 | ((ir-node ir-inner-node) 482 | (future-predecessor ir-node-with-successor)) 483 | (let ((a future-predecessor) 484 | (b ir-node) 485 | (c (ir-node-successor future-predecessor))) 486 | (setf (ir-node-%successor b) c) 487 | (setf (ir-node-%predecessor b) a) 488 | (setf (ir-node-%successor a) b) 489 | (setf (ir-node-%predecessor c) b)) 490 | ir-node) 491 | 492 | (defmethod extract-ir-node 493 | ((ir-node ir-inner-node)) 494 | (let ((a (ir-node-predecessor ir-node)) 495 | (b ir-node) 496 | (c (ir-node-successor ir-node))) 497 | (setf (ir-node-%successor a) c) 498 | (setf (ir-node-%predecessor c) a) 499 | (setf (ir-node-%successor b) b) 500 | (setf (ir-node-%predecessor b) b) 501 | ir-node)) 502 | 503 | (defmethod copy-ir-value (context (ir-value ir-value) &optional (ntype (typo:universal-ntype))) 504 | (let* ((declared-type (ir-value-declared-type ir-value)) 505 | (declared-ntype (typo:type-specifier-ntype declared-type)) 506 | (derived-ntype (ir-value-derived-ntype ir-value))) 507 | (values 508 | (alexandria:ensure-gethash 509 | ir-value 510 | *ir-value-copies* 511 | (make-instance 'ir-value 512 | :declared-type declared-type 513 | :derived-ntype 514 | (typo:ntype-intersection 515 | declared-ntype 516 | (typo:ntype-intersection derived-ntype ntype))))))) 517 | 518 | (defmethod copy-ir-node (context (ir-loop ir-loop)) 519 | (let* ((variable (copy-ir-value context (ir-loop-variable ir-loop))) 520 | (ir-node (make-instance 'ir-node-with-outputs 521 | :outputs (list variable)))) 522 | (change-class ir-node 'ir-loop 523 | :inputs (mapcar (alexandria:curry #'copy-ir-value context) (ir-node-inputs ir-loop)) 524 | :variable variable 525 | :test (copy-ir-block context (ir-loop-test ir-loop) ir-node) 526 | :body (copy-ir-block context (ir-loop-body ir-loop) ir-node)))) 527 | 528 | (defmethod copy-ir-node (context (ir-call ir-call)) 529 | (with-accessors ((fnrecord ir-call-fnrecord) 530 | (inputs ir-node-inputs) 531 | (outputs ir-node-outputs)) ir-call 532 | (make-instance 'ir-call 533 | :fnrecord fnrecord 534 | :inputs (mapcar (alexandria:curry #'copy-ir-value context) inputs) 535 | :outputs 536 | (if (eql outputs '*) 537 | '* 538 | (mapcar (alexandria:curry #'copy-ir-value context) outputs))))) 539 | 540 | (defmethod copy-ir-node (context (ir-if ir-if)) 541 | (let ((ir-node (make-instance 'ir-node))) 542 | (change-class ir-node 'ir-if 543 | :inputs (mapcar (alexandria:curry #'copy-ir-value context) 544 | (ir-node-inputs ir-if)) 545 | :outputs (mapcar (alexandria:curry #'copy-ir-value context) 546 | (ir-node-outputs ir-if)) 547 | :then (copy-ir-block context (ir-if-then ir-if) ir-node) 548 | :else (copy-ir-block context (ir-if-else ir-if) ir-node)))) 549 | 550 | (defmethod copy-ir-node (context (ir-construct ir-construct)) 551 | (make-instance 'ir-construct 552 | :form (ir-construct-form ir-construct) 553 | :outputs (mapcar (alexandria:curry #'copy-ir-value context) 554 | (ir-node-outputs ir-construct)))) 555 | 556 | (defmethod copy-ir-node (context (ir-enclose ir-enclose)) 557 | (let ((ir-node (make-instance 'ir-node))) 558 | (change-class ir-node 'ir-enclose 559 | :body (copy-ir-block context (ir-enclose-body ir-enclose) ir-node) 560 | :argument-values (mapcar (alexandria:curry #'copy-ir-value context) 561 | (ir-enclose-argument-values ir-enclose))))) 562 | 563 | (defmethod copy-ir-block (context (ir-node ir-node) dominator) 564 | (multiple-value-bind (ir-initial-node ir-final-node) 565 | (make-ir-initial-and-ir-final-node dominator) 566 | (let ((*blocks* (cons ir-final-node *blocks*))) 567 | (map-block-inner-nodes (alexandria:curry #'copy-ir-node context) ir-node)) 568 | ir-initial-node)) 569 | 570 | (defun replace-node-outputs (node replacement-outputs) 571 | (let* ((node-outputs (ir-node-outputs node))) 572 | (unless (and (eql node-outputs '*) 573 | (eql replacement-outputs '*)) 574 | (loop for node-output in node-outputs 575 | for replacement-output in replacement-outputs do 576 | (setf (gethash node-output *ir-value-copies*) 577 | replacement-output))))) 578 | -------------------------------------------------------------------------------- /code/ir/ir-isl-input.lisp: -------------------------------------------------------------------------------- 1 | (in-package :loopus.ir) 2 | 3 | ;; First, some variable. Lot of them 4 | ;; Then, the code 5 | 6 | ;; To create points on the domain side 7 | (defvar *size-domain*) 8 | ;; Needs to be even. 2 per loop variable 9 | (defvar *space-domain*) 10 | 11 | ;; To create points on the range side 12 | (defvar *size-range*) 13 | ;; A[i, j] consumes 3 spot (1 for the array, 1 for i, 1 for j) 14 | (defvar *space-range*) 15 | 16 | ;; The space of maps (domain -> range) 17 | (defvar *space-map-domain-range*) 18 | 19 | ;; The space of schedule (domain -> domain) 20 | (defvar *space-map-schedule*) 21 | 22 | ;; How many free variable we can have 23 | (defvar *size-free-parameters*) 24 | 25 | ;; Add parameters from free variables 26 | ;; Position can be found with the hashtable 27 | (defvar *free-variable-to-index*) 28 | 29 | ;; hashtable of ir-construct-node to position of the identifier 30 | (defvar *construct-to-identifier*) ;; ir-construct-node to position (integer) 31 | (defvar position-next-free-variable) ;; at first it's *size-domain*. Gets incf each time 32 | 33 | ;; Definition of variables that will hold the set/map of domain/read/write/schedule 34 | (defvar *set-domain*) 35 | (defvar *map-read*) 36 | (defvar *map-write*) 37 | (defvar *map-schedule*) 38 | 39 | ;; Modify a map to add it another map (union of both) (same for push-set) 40 | (defmacro push-map (map object) 41 | `(setf ,map (isl:union-map-union ,map ,object))) 42 | (defmacro push-set (set object) 43 | `(setf ,set (isl:union-set-union ,set ,object))) 44 | 45 | ;; Generate an unique number for each ir-node 46 | (defvar *counter-range*) ; the value they'll have. It's just increment by 1 each time 47 | (defvar *all-irnodes*) ; the map ir-node -> int (this unique value) 48 | (defun uniquenumber (producer) 49 | (let ((v (if ; todo refactor ? 50 | (ir-construct-p producer) 51 | (ir-construct-form producer) 52 | producer))) 53 | (values 54 | (alexandria:ensure-gethash v *all-irnodes* (incf *counter-range*))))) 55 | 56 | ;; List of all loop-variables of loops we are currently in 57 | (defvar *loop-variables*) 58 | (defun is-loop-variable (node) 59 | (position node *loop-variables*)) 60 | 61 | ;; List of loop bounds 62 | (defvar *loop-bounds*) 63 | 64 | 65 | ;;;;;;;;;;;;;;; 66 | ;; DOMAIN 67 | ;;;;;;;;;;;;;;; 68 | 69 | ;; We want to create the set [*counter*1, loop-var1, *counter*2, loop-var2, ...] : start <= loop-var1 < end; start <= ... 70 | ;; We start from universe { [*, *] } 71 | ;; Add constraint for each loop-var to have { [*counter*, loop-var] : start <= loop-var < end } 72 | ;; The function that does what is described just above is create-new-point-domain, 2 s-expr below 73 | 74 | 75 | ;; Add a constant value to the constraint. Can be a known value or a variable 76 | (defun add-constant-constraint (constraint value i delta) 77 | ;; 3 cases: 78 | ;; + integer -> just add the value 79 | ;; + loop variable -> *loop-variables* has the first value the most inner loop so we need to reverse it 80 | ;; + free variable -> pick from *construct-to-identifier* 81 | 82 | ;; Delta is here because constraints on isl are <=, and loopus it's < 83 | (if (integerp value) 84 | ;; integer 85 | (isl:inequality-constraint-set-constant constraint (isl:value (+ delta (* i value)))) 86 | (let ((idx-loop-variable (position value *loop-variables*))) 87 | (if idx-loop-variable 88 | ;; loop variable 89 | (isl:inequality-constraint-set-coefficient 90 | (isl:inequality-constraint-set-constant constraint (isl:value delta)) ; Add the -1 constant in the inequality 91 | :dim-set (1+ idx-loop-variable) 92 | (isl:value i)) 93 | (let ((idx-free-variable 94 | (alexandria:ensure-gethash ; position-next-free-variable is incremented only when not found 95 | (ir-construct-form (ir-value-producer value)) 96 | *construct-to-identifier* 97 | (incf position-next-free-variable)))) 98 | (if idx-free-variable 99 | ;; free variable 100 | (isl:inequality-constraint-set-coefficient 101 | (isl:inequality-constraint-set-constant constraint (isl:value delta)) 102 | :dim-param idx-free-variable 103 | (isl:value i)) 104 | (break "can't happen"))))))) 105 | 106 | (defvar *counter-domain*) ; List of counters 107 | (defvar *global-counter*) ; Global counter to rememeber which is what instruction 108 | (defun create-new-point-domain () 109 | ;; The structure we want to have: see commentary above. Start from universe, and create each part 110 | (let ((result (isl:basic-set-universe *space-domain*)) 111 | (local-space-domain (isl:local-space-from-space *space-domain*))) 112 | ;; Part for each loop var 113 | (loop for p below (* 2 *current-depth*) by 2 do 114 | ;; First, the creation of the global counter, and then the loop variable 115 | (let* ((constraint (isl:make-equality-constraint local-space-domain)) 116 | ;; Creation of the counter 117 | (constraint (isl:equality-constraint-set-constant constraint (isl:value (nth (/ p 2) *counter-domain*)))) 118 | (constraint (isl:equality-constraint-set-coefficient constraint :dim-set p (isl:value -1))) 119 | (_ (setf result (isl:basic-set-add-constraint result constraint))) 120 | ;; Creation the 2nd part: start <= i < end with the good step 121 | (bounds (nth (/ p 2) (reverse *loop-bounds*))) 122 | (p (1+ p)) 123 | ;; The variable at the very left is the outer loop, so it's the good order 124 | (start-value (first bounds)) 125 | (end-value (second bounds)) 126 | (step-value (third bounds)) 127 | (inputs (nth 3 bounds)) 128 | ;; Creation of the step: exists j such that i = step*j + start 129 | (aff (isl:create-var-affine local-space-domain :dim-set p)) 130 | ;; todo general case 131 | ;; if the startvalue isn't an integer then apply-set doesn't work anymore 132 | ;; (gives the universe). Todo add constraint i1 = o1 for all 1? 133 | ;; ?? or no ? todo check 134 | ;;(_ (assert (integerp start-value))) 135 | ;; if step is not known, the loop direction is unknown, and not sure what I should do 136 | ;; but the user probably know the loop direction anyway, maybe better to ask him 137 | (_ (assert (integerp step-value))) 138 | (aff (isl:affine-mul aff (isl:create-val-affine local-space-domain (isl:value step-value)))) 139 | (aff (isl:affine-add aff 140 | (affine-expression-from-loopus-ast (first inputs) local-space-domain))) 141 | ;;(isl:create-val-affine local-space-domain (isl:value start-value)))) 142 | (affmap (isl:basic-map-from-affine aff)) 143 | (affmap (isl:basic-map-insert-dimension affmap :dim-out 0 p)) 144 | (affmap (isl:basic-map-insert-dimension affmap :dim-out (1+ p) (- (* 2 *current-depth*) p))) 145 | (_ (setf result (isl:basic-set-intersect result (isl::basic-set-apply result affmap)))) 146 | ;; Creation of start value: start <= i 147 | (constraint (isl:make-inequality-constraint local-space-domain)) 148 | (constraint (add-constant-constraint constraint start-value -1 0)) 149 | (constraint (isl:inequality-constraint-set-coefficient constraint :dim-set p (isl:value 1))) 150 | (_ (setf result (isl:basic-set-add-constraint result constraint))) 151 | ;; Creation of end value: i < end 152 | (constraint (isl:make-inequality-constraint local-space-domain)) 153 | (constraint (add-constant-constraint constraint end-value 1 -1)) ; here -1 because loopus is "<" and isl is "<=" 154 | (constraint (isl:inequality-constraint-set-coefficient constraint :dim-set p (isl:value -1))) 155 | (_ (setf result (isl:basic-set-add-constraint result constraint)))))) 156 | ;; Last counter 157 | (let* ((constraint (isl:make-equality-constraint local-space-domain)) 158 | (constraint (isl:equality-constraint-set-constant constraint (isl:value *global-counter*))) 159 | (constraint (isl:equality-constraint-set-coefficient constraint :dim-set (* 2 *current-depth*) (isl:value -1)))) 160 | (setf result (isl:basic-set-add-constraint result constraint))) 161 | ;; Now we have [*counter-domain*, i, ...] 162 | ;; Part to fill the rest 163 | (loop for p from (1+ (* 2 *current-depth*)) below *size-domain* do 164 | (let* ((constraint (isl:make-equality-constraint local-space-domain)) 165 | (constraint (isl:equality-constraint-set-constant constraint (isl:value -1))) 166 | (constraint (isl:equality-constraint-set-coefficient constraint :dim-set p (isl:value -1)))) 167 | (setf result (isl:basic-set-add-constraint result constraint)))) 168 | ;; Now we have what we wanted 169 | (isl:basic-set-union-set result))) 170 | 171 | 172 | ;;;;;;;;;;;;;;; 173 | ;; READ/WRITE 174 | ;;;;;;;;;;;;;;; 175 | 176 | ;; This will get called on each instruction that can read or write 177 | 178 | ;; First, create the affine expression 179 | ;; Todo merge this with add-constant-constraint 180 | (defun affine-expression-from-loopus-ast (ast local-space) 181 | ;; maybe ir-if 182 | ;; todo generic function 183 | ;; If it's a call, we do a recursive call to ourself :-) 184 | (if (ir-call-p (ir-value-producer ast)) 185 | (let* ((the-call (ir-value-producer ast)) 186 | (a (first (ir-node-inputs the-call))) 187 | (b (second (ir-node-inputs the-call))) 188 | ;; We call recursively on a and b. "this" is the current function 189 | (this (lambda (arg) (affine-expression-from-loopus-ast arg local-space))) 190 | (new-a (funcall this a)) 191 | (new-b (funcall this b))) 192 | ;; If one of the expression isn't recognized, we are not recognized too 193 | (if (not (and new-a new-b)) 194 | nil 195 | ;; integer+ integer- integer* takes 2 arguments due to typo 196 | ;; todo generalize by checking if types and number of arguments are ok to do the thing below 197 | (case (typo:fnrecord-name (ir-call-fnrecord the-call)) 198 | (typo:integer+ (isl:affine-add new-a new-b)) 199 | (typo:integer- (isl:affine-sub new-a new-b)) 200 | (typo:integer* (isl:affine-mul new-a new-b)) 201 | ;; otherwise universe set todo 202 | ;; todo rationnal 203 | #+or(typo:integer/ (isl:affine-div new-a new-b)) 204 | (otherwise 205 | ;; Otherwise, we don't know/recognize what it is. Return the universe 206 | nil)))) 207 | ;; Otherwise, base case 208 | (let ((pos-variable (is-loop-variable ast))) 209 | (if pos-variable 210 | ;; Loop variable 211 | (isl:create-var-affine local-space :dim-set (1+ (* 2 pos-variable))) 212 | ;; Integer 213 | (if (and (listp (ir-value-derived-type ast)) (integerp (second (ir-value-derived-type ast)))) 214 | (isl:create-val-affine local-space (isl:value (second (ir-value-derived-type ast)))) 215 | ;; Free variable 216 | (let ((idx-free-variable 217 | (alexandria:ensure-gethash 218 | (ir-construct-form (ir-value-producer ast)) 219 | *construct-to-identifier* 220 | (incf position-next-free-variable)))) 221 | (isl:create-var-affine local-space :dim-param idx-free-variable))))))) 222 | 223 | (defun get-value (node) 224 | (let* ((producer (ir-value-producer node))) 225 | (uniquenumber producer))) 226 | (defun create-new-point-range-new (&rest args) 227 | ;; Creation of the result map, and adding the constraint of the array 228 | (let* ((result (isl:basic-map-universe *space-map-domain-range*)) 229 | (local-space (isl:local-space-from-space *space-map-domain-range*)) 230 | (local-space-domain (isl:local-space-from-space *space-domain*)) 231 | (constraint (isl:make-equality-constraint local-space)) 232 | (constraint (isl:equality-constraint-set-constant constraint (isl:value (get-value (first args))))) 233 | (constraint (isl:equality-constraint-set-coefficient constraint :dim-out 0 (isl:value -1))) 234 | (result (isl:basic-map-add-constraint result constraint))) 235 | ;; The, we do all arguments of the read. So if (aref a b c 1 3) we do for a b c 1 3 236 | ;; This loop is now useless that we have row-major-aref only. We keep it if we want to go back to aref 237 | ;; Comments below are written for the aref code 238 | (loop for idx from 1 below (length args) do 239 | ;; For everything we read, we create an affixe expression of what it is, and create the associated map 240 | (let* ((affine-expression (affine-expression-from-loopus-ast (nth idx args) local-space-domain)) 241 | (new-map (if affine-expression 242 | (isl:basic-map-from-affine affine-expression) 243 | (isl:basic-map-universe *space-map-domain-range*)))) 244 | ;; The map we just created is [o0, o1, ...] -> [our expression] 245 | ;; (Unless affine-expression is nil (not recognized), and then we already have the good map) 246 | (when affine-expression 247 | ;; We need to extend the range to obtain [o0, o1, ...] -> [i0, our expression, ...] 248 | ;; We add first everything before; then everything after 249 | ;; idx here is (+ 1 (1- idx)) ; 1 is for the array, (1- idx) is the every loop variable before 250 | (setf new-map (isl:basic-map-insert-dimension new-map :dim-out 0 idx)) 251 | ;; About 0, and (1+ idx). It's the insertion position. 252 | ;; The final result we want is [smth, our expression, smth] 253 | ;; So first, we insert before, hence the 0 254 | ;; Then, we insert just after, hence (1+ idx). We inserted idx elements, so we have (1+ idx) total elements 255 | (setf new-map (isl:basic-map-insert-dimension new-map :dim-out (1+ idx) (- *size-range* (1+ idx))))) 256 | ;; Now we have the good map 257 | (setf result (isl:basic-map-intersect result new-map)))) 258 | ;; Fill for the rest with a single value 259 | ;; Same, useless. Keep it just in case 260 | #+or(loop for p from (length args) below *size-range* do 261 | (let* ((constraint (isl:make-equality-constraint local-space)) 262 | (constraint (isl:equality-constraint-set-constant constraint (isl:value -1))) 263 | (constraint (isl:equality-constraint-set-coefficient constraint :dim-out p (isl:value -1)))) 264 | (setf result (isl:basic-map-add-constraint result constraint)))) 265 | result)) 266 | 267 | 268 | ;;;;;;;;;;;;;;; 269 | ;; SCHEDULE 270 | ;;;;;;;;;;;;;;; 271 | 272 | (defun create-map-schedule (timestamp) 273 | (isl:union-set-identity timestamp)) 274 | 275 | ;; Old version 276 | ;; I'm a clown and it's just (identity domain domain) ? 277 | ;; Keep it just in case 278 | #+or(defun create-map-schedule (&rest args) 279 | (let* ((result (isl:basic-map-universe *space-map-schedule*)) 280 | (*space-map-schedule* (isl:local-space-from-space *space-map-schedule*)) 281 | (bot (isl:make-equality-constraint *space-map-schedule*)) 282 | (bot (isl:equality-constraint-set-constant bot (isl:value *counter-domain*))) 283 | (bot (isl:equality-constraint-set-coefficient bot :dim-in 0 (isl:value -1))) 284 | (result (isl:basic-map-add-constraint result bot)) 285 | (bot (isl:make-equality-constraint *space-map-schedule*)) 286 | (bot (isl:equality-constraint-set-constant bot (isl:value *counter-domain*))) 287 | (bot (isl:equality-constraint-set-coefficient bot :dim-out 0 (isl:value -1))) 288 | (result (isl:basic-map-add-constraint result bot))) 289 | ;; Loop for each variable 290 | (loop for idx from 0 below *current-depth* do 291 | ;; Now, for each loop variable, we map it to the correct left part 292 | (let* ((bot (isl:make-equality-constraint *space-map-schedule*)) 293 | (pos-variable (is-loop-variable (nth idx (first args)))) 294 | (bot (isl:equality-constraint-set-coefficient 295 | bot 296 | :dim-in (+ 1 pos-variable) 297 | (isl:value -1))) 298 | (bot (isl:equality-constraint-set-coefficient 299 | bot 300 | :dim-out (1+ idx) 301 | (isl:value 1))) 302 | (_ (setf result (isl:basic-map-add-constraint result bot)))))) 303 | ;; Loop for the rest 304 | (loop for idx from *current-depth* below *size-domain* do 305 | (let* ((bot (isl:make-equality-constraint *space-map-schedule*)) 306 | (bot (isl:equality-constraint-set-coefficient 307 | bot 308 | :dim-in idx 309 | (isl:value -1))) 310 | (bot (isl:equality-constraint-set-coefficient 311 | bot 312 | :dim-out idx 313 | (isl:value 1))) 314 | (_ (setf result (isl:basic-map-add-constraint result bot)))))) 315 | (isl:basic-map-union-map result))) 316 | 317 | 318 | 319 | ;; Function that'll be mapped on all ir nodes 320 | (defgeneric update-node (node)) 321 | (defmethod update-node ((node ir-node))) 322 | 323 | (defmacro my-incf (v) 324 | `(setf ,v 325 | ;;(1+ ,v))) 326 | (* (+ 1 ,v) 2))) 327 | ;; todo when it packs loop, instead of 0, c, 0, c, 0 it does 0, c, 0, c, c 328 | ;; the problem is the last value becomes a loop variable, so it's just annoying to unroll instruction by hand 329 | ;; for instance if there are 2 consecutive loop, need to parse the end value of the loop (it can be an expression, depend on parameters, ... :/) 330 | 331 | (defvar *id-to-expression*) ; int -> loopus node 332 | (defvar *depth-node*) ; loopus for node -> depth 333 | (defvar *current-depth*) 334 | 335 | ;; If a subexpression read/write, then the top expression read/write too 336 | ;; So (1+ (aref ...)) have the same read as (aref ...) 337 | (defvar *node-to-read*) 338 | (defvar *node-to-write*) 339 | 340 | ;; Where we write in the range to represent that we have side effect 341 | (defvar *set-of-side-effect*) 342 | 343 | ;; Function call 344 | ;; Right now, only check if it's aref/setf, otherwise it does nothing 345 | (defmethod update-node ((node ir-call)) 346 | ;; Structure of the function is the following: 347 | ;; 348 | ;; The goal is to add timestamp/read/write/schedule to our special parameters 349 | ;; Current timestamp is the set of timestamp corresponding to this single instruction 350 | ;; Read/write maps that maps timestamp to data in memory. Possible when (or can-read can-write) 351 | ;; For timestamp, if it's a instructon outisde a loop, the set will only have a single element 352 | ;; Otherwise if it's in a "i" loop, it'd be for instance { [0, i]: start <= i < end } 353 | ;; For each point of this set, a read/write operation is maybe performed 354 | ;; We want to add to *map-read/write* the map, for instance, { [0, i] -> A[i, 0] } if A[i, 0] is read 355 | ;; 356 | ;; First, we add to *node-to-read/write* if the loopus node can read/write 357 | ;; Then, we propagate this info. If one of your input can read, then you can too! 358 | ;; Finally, if a instruction will be in the generated ast (variable we-keep-it) 359 | ;; then we log the timestamp and everything it can read/write to our special variables 360 | (let* ((function-call node) 361 | (args (ir-node-inputs node)) 362 | ;; We only support row-major-aref here. Todo patch that it's implementation depend 363 | (can-read (eql 'row-major-aref (typo:fnrecord-name (ir-call-fnrecord node)))) 364 | (can-write (eql 'sb-kernel:%set-row-major-aref (typo:fnrecord-name (ir-call-fnrecord node)))) 365 | ;; For now we keep expression that have no outputs (to catch for instance 'print) 366 | ;; Todo catch everything flushable or something else 367 | ;; The generated ast in the end will have only expression that have side effects 368 | (has-side-effect (eql 'print (typo:fnrecord-name (ir-call-fnrecord node)))) 369 | (we-keep-it (not (ir-node-outputs node))) 370 | (current-timestamp (create-new-point-domain))) 371 | ;; It's the first time we encounter node, no value is in the hashtable, so we initialize here 372 | (setf (gethash node *node-to-read*) (isl:union-map-empty *space-map-domain-range*)) 373 | (setf (gethash node *node-to-write*) (isl:union-map-empty *space-map-domain-range*)) 374 | ;; Computation if it read/write. Won't modify special variables, only *node-to-read/write* 375 | (when (or can-read can-write) 376 | ;; Either (row-major-aref array idx), or (setf-row-major-aref array idx value) 377 | ;; Todo, the setf thing is implementation dependant too I guess 378 | (let* ((what-is-read/wrote-in-order (if can-read args (butlast args))) 379 | (full-map-of-read/write 380 | (isl:basic-map-union-map 381 | (apply #'create-new-point-range-new what-is-read/wrote-in-order))) 382 | (map-of-read/write 383 | (isl:union-map-intersect-domain full-map-of-read/write current-timestamp))) 384 | (when can-read (push-map (gethash node *node-to-read*) full-map-of-read/write)) 385 | (when can-write (push-map (gethash node *node-to-write*) full-map-of-read/write)))) 386 | ;; Propagate read/write information from subexpressions 387 | (loop for node in args do 388 | (let* ((node (ir-value-producer node)) 389 | (read (gethash node *node-to-read*)) 390 | (write (gethash node *node-to-write*))) 391 | ;; node may not be an ir-call, so read/write can be nil instead of union-map-empty 392 | (when read (push-map (gethash node *node-to-read*) read)) 393 | (when write (push-map (gethash node *node-to-write*) write)))) 394 | ;; If it has side effect, we represent that by writting to a special point in the range 395 | (when has-side-effect 396 | (push-map (gethash node *node-to-write*) 397 | (isl:union-map-from-domain-and-range current-timestamp *set-of-side-effect*))) 398 | ;; When we keep the expression, add everything to the special variables 399 | (when we-keep-it 400 | ;; Both following s-expr remember what expressions needs to be included in the final code 401 | (setf (gethash *global-counter* *id-to-expression*) node) 402 | (push-set *set-domain* current-timestamp) 403 | (let ((read (gethash node *node-to-read*)) 404 | (write (gethash node *node-to-write*))) 405 | (push-map *map-read* (isl:union-map-intersect-domain read current-timestamp)) 406 | (push-map *map-write* (isl:union-map-intersect-domain write current-timestamp))) 407 | (push-map *map-schedule* (create-map-schedule current-timestamp)) 408 | (my-incf *global-counter*)))) 409 | 410 | (defun parse-bound (value) 411 | (let ((ntype (ir-value-derived-ntype value))) 412 | (if (typo.ntype:eql-ntype-p ntype) 413 | (typo:eql-ntype-object ntype) 414 | value))) 415 | 416 | ;; todo turn this into a cl isl 417 | (defun parse-end-bound (value variable) 418 | ;; We only do something (now) when the loop is know 419 | ;; otherwise todo loop end is a free variable 420 | (assert (= (length (ir-node-inputs value)) 1)) 421 | ;; otherwise, the return value is the node just before the final node 422 | (let* ((boolean (typo:eql-ntype-object (ir-value-derived-ntype (first (ir-node-inputs value))))) 423 | (branch-taken (if boolean (ir-then value) (ir-if-else value))) 424 | (ir-call (ir-node-predecessor (ir-final-node branch-taken))) 425 | ;; .................. 426 | (ir-call (ir-value-producer (second (ir-node-inputs ir-call)))) 427 | (_ (assert (= 2 (length (ir-node-inputs ir-call))))) 428 | (f (typo:fnrecord-name (ir-call-fnrecord ir-call))) 429 | (a (first (ir-node-inputs ir-call))) 430 | (b (second (ir-node-inputs ir-call)))) 431 | (cond 432 | ((and (eql a variable) (eql f '<)) (parse-bound b)) 433 | ((and (eql a variable) (eql f '<=)) (parse-bound (1+ b))) 434 | ;; "a > variable" --> the end is a 435 | ((and (eql b variable) (eql f '>)) (parse-bound a)) 436 | ((and (eql b variable) (eql f '>=)) (parse-bound (1+ a))) 437 | (t (break "We cannot optimize this loop for now"))))) 438 | 439 | ;; Todo handle lexical scope 440 | (defmethod update-node ((node ir-loop)) 441 | ;; First, we add informations (the current loop variable, the depth, etc...) 442 | ;; And then, last s-expr, call recursively on the body of the loop! 443 | ;; List of loop variables 444 | (let* ((*loop-variables* (append *loop-variables* (list (ir-loop-variable node)))) 445 | ;; Current depth we are in 446 | (_ (setf (gethash node *depth-node*) *current-depth*)) 447 | (*current-depth* (1+ *current-depth*)) 448 | (*counter-domain* (append *counter-domain* (list *global-counter*))) 449 | ;; Loop bounds 450 | (inputs (ir-node-inputs node)) 451 | (start (parse-bound (first inputs))) 452 | (step (parse-bound (second inputs))) 453 | (end (parse-end-bound 454 | (ir-node-predecessor (ir-final-node (ir-loop-test node))) 455 | (ir-loop-variable node))) 456 | (*loop-bounds* (cons (list start end step inputs) *loop-bounds*))) 457 | ;; Recursive call 458 | (map-block-inner-nodes #'update-node (ir-loop-body node)) 459 | ;; No need to restore the hashtable, every node is different ? 460 | ;; Also it's used in the output part, so removing the hash will break it 461 | ;;(remhash node *depth-node*) 462 | )) 463 | --------------------------------------------------------------------------------