├── .travis.yml ├── INSTALL ├── Makefile ├── README ├── TODO ├── aggtransformer.lisp ├── ast.lisp ├── bt2c.lisp ├── cl-meld.asd ├── compare.lisp ├── compile.lisp ├── conf.lisp ├── context.lisp ├── count.sh ├── directives.lisp ├── external.lisp ├── install.lisp ├── load.lisp ├── localize.lisp ├── macros.lisp ├── magic.mgc ├── manip.lisp ├── meld.lisp ├── models ├── base.lisp └── parallel.lisp ├── optimize.lisp ├── output.lisp ├── package.lisp ├── parser.lisp ├── print.lisp ├── scripts ├── Makefile ├── README ├── meld-compile-directory ├── meld-compile-file ├── meld-compile-from-directory ├── standalone.sh └── test.sh ├── search.lisp ├── snap-stanford.lisp ├── stratification.lisp ├── topology.lisp ├── transform.lisp ├── typecheck.lisp ├── types.lisp ├── util.lisp ├── vm.lisp └── yacc-comments.patch /.travis.yml: -------------------------------------------------------------------------------- 1 | language: lisp 2 | script: 3 | - cd scripts && sh standalone.sh && sh test.sh && rm -rf compile 4 | before_install: 5 | - sudo apt-get update -qq 6 | install: 7 | - sudo apt-get install sbcl realpath 8 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | - Requirements: 2 | sbcl, g++, make, git 3 | 4 | - Download compiler and virtual machine: 5 | git clone http://github.com/flavioc/cl-meld (compiler) 6 | git clone http://github.com/flavioc/meld (virtual machine) 7 | 8 | - Install compiler 9 | 10 | $ cd cl-meld/scripts 11 | # Will install quicklisp and all required packages 12 | $ bash standalone.sh 13 | # Move quick lisp to home directory 14 | $ mv compile ~/quicklisp 15 | # Install compiler scripts 16 | $ sudo make install 17 | $ cd .. 18 | $ ln -sf $PWD/cl-meld.asd ~/quicklisp/local-projects/ 19 | 20 | - Compile and run programs 21 | 22 | Go to 'meld', the virtual machine directory, and read the README file. 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: meld 3 | 4 | meld: 5 | buildapp --asdf-path $(PWD) \ 6 | --load-system cl-meld \ 7 | --eval '(defun main (args) (cl-meld:meld-compile (second args) (third args)))' \ 8 | --entry main \ 9 | --output meld 10 | 11 | clean: 12 | rm -f meld 13 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is a compiler for the Meld programming language written in Common Lisp. 2 | 3 | Please see this paper for more information on Meld: 4 | A Language for Large Ensembles of Independently Executing Nodes: 5 | http://www.cs.cmu.edu/~mpa/papers/ashley-rollman-iclp09.pdf 6 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | 2 | - Some constraints must be pushed into the ITER instruction 3 | - do not use if for simple int comparisons and stuff like that 4 | - it would be cool do put list matching code on the ITER instruction... someday 5 | -------------------------------------------------------------------------------- /aggtransformer.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (defun valid-aggregate-p (agg) 4 | (let ((agg (aggregate-agg agg)) 5 | (typ (aggregate-type agg))) 6 | (case agg 7 | (:first t) 8 | (:sum 9 | (or (type-int-p typ) 10 | (type-float-p typ) 11 | (if (type-list-p typ) 12 | (let ((sub (type-list-element typ))) 13 | (or (type-int-p sub) 14 | (type-float-p sub)))))) 15 | ((:min :max) 16 | (eq-or typ :type-int :type-float))))) 17 | 18 | (defun update-aggregate-head (head body modifier edge-name agg-name get-fun) 19 | ;; If this rule produces an aggregate fact, push the route node into the last 20 | ;; argument or else put the home node (for local rules) 21 | (let ((head-subs (filter #L(equal (subgoal-name !1) agg-name) (get-subgoals head)))) 22 | (when head-subs 23 | (multiple-value-bind (node thread) (find-host-nodes-head-only head) 24 | (let* ((routes (filter #L(equal (subgoal-name !1) edge-name) (get-subgoals body))) 25 | host) 26 | (if routes 27 | (setf host (funcall get-fun (subgoal-args (first routes)))) 28 | (unless (aggregate-mod-includes-home-p modifier) 29 | (aggregate-mod-include-home modifier))) 30 | (assert host) 31 | (loop for sub in head-subs 32 | do (push-end host (subgoal-args sub)))))))) 33 | 34 | 35 | (defun update-aggregate-input (modifier edge-name agg-name get-fun) 36 | "For an aggregate that has an INPUT/OUTPUT modifier, executes source code transformations 37 | that puts the input/output node as the last argument of the aggregate" 38 | (do-all-const-axioms (:subgoal sub) 39 | (update-aggregate-head (list sub) nil modifier edge-name agg-name get-fun)) 40 | (do-all-var-axioms (:head head) 41 | (update-aggregate-head head nil modifier edge-name agg-name get-fun)) 42 | (do-rules (:head head :body body) 43 | (update-aggregate-head head body modifier edge-name agg-name get-fun) 44 | ;; Add an unnamed variable for clauses that use the aggregated result. 45 | (let ((body-subs (filter #L(equal (subgoal-name !1) agg-name) (get-subgoals body)))) 46 | (loop for sub in body-subs 47 | do (push-end (generate-random-var) (subgoal-args sub))))) 48 | (let ((def (lookup-definition agg-name))) 49 | (assert (not (null def))) 50 | (push-end :type-addr (definition-types def)))) 51 | 52 | (defun valid-aggregate-modifier-p (agg-name agg) 53 | (let ((aggmod (aggregate-mod agg))) 54 | (cond 55 | ((null aggmod) t) 56 | ((aggregate-mod-is-immediate-p aggmod) t) 57 | ((aggregate-mod-is-input-p aggmod) 58 | (let* ((name (aggregate-mod-io-name aggmod)) 59 | (def (lookup-definition name)) 60 | (ret (and def (is-route-p def)))) 61 | (when ret 62 | (update-aggregate-input aggmod name agg-name #'first)) 63 | ret)) 64 | ((aggregate-mod-is-output-p aggmod) 65 | (let* ((name (aggregate-mod-io-name aggmod)) 66 | (def (lookup-definition name)) 67 | (ret (and def (is-route-p def)))) 68 | (when ret 69 | (update-aggregate-input aggmod name agg-name #'second)) 70 | ret))))) 71 | 72 | (defun check-aggregates (name typs) 73 | (let ((total (count-if #'aggregate-p typs))) 74 | (unless (<= total 1) 75 | (error 'type-invalid-error 76 | :text (concatenate 'string "tuple " name " must have only one aggregate"))) 77 | (alexandria:when-let ((agg (find-if #'aggregate-p typs))) 78 | (unless (valid-aggregate-p agg) 79 | (error 'type-invalid-error 80 | :text (tostring "invalid aggregate type: ~a" agg))) 81 | (unless (valid-aggregate-modifier-p name agg) 82 | (error 'type-invalid-error 83 | :text "invalid aggregate modifier"))))) 84 | 85 | (defun delete-from-body (clause construct) 86 | (setf (clause-body clause) (remove-tree-first construct (clause-body clause)))) 87 | 88 | (defparameter *agg-construct-counter* 0) 89 | (defun generate-new-agg-pred () 90 | (incf *agg-construct-counter*) 91 | (tostring "__agg_construct_~a" *agg-construct-counter*)) 92 | 93 | (defun unique-subgoal-in-head-p (clause) 94 | (with-clause clause (:head head :body body) 95 | (and (null body) 96 | (not (null head)) 97 | (= (length head) 1) 98 | (subgoal-p (first head))))) 99 | 100 | (defun carry-total-subgoal-p (subgoal var) 101 | (with-subgoal subgoal (:args args) 102 | (when (>= (length args) 2) 103 | (var-eq-p var (second args))))) 104 | 105 | (defun body-from-same-remote-p (body orig) 106 | (let (var) 107 | (do-subgoals body (:args args) 108 | (if (null var) 109 | (cond 110 | ((var-eq-p orig (first args)) 111 | (return-from body-from-same-remote-p nil)) 112 | (t 113 | (setf var (first args)))) 114 | (unless (var-eq-p (first args) var) 115 | (return-from body-from-same-remote-p nil)))) 116 | var)) 117 | 118 | (defun uses-route-subgoal-from-p (body host remote) 119 | (do-subgoals body (:name name :subgoal subgoal :args args) 120 | (when (and (>= (length args) 2) 121 | (var-eq-p (first args) remote) 122 | (var-eq-p (second args) host)) 123 | (let ((def (lookup-definition name))) 124 | (when (is-route-p def) 125 | (return-from uses-route-subgoal-from-p subgoal))))) 126 | nil) 127 | 128 | (defun get-agg-options-for-remote (body host to sub-name) 129 | (let ((rem-var (body-from-same-remote-p body host)) 130 | (agg-options nil)) 131 | (when rem-var 132 | (awhen (uses-route-subgoal-from-p body host rem-var) 133 | (setf agg-options `(:input ,(subgoal-name it))) 134 | (let* ((new-subgoal-0 (make-subgoal sub-name 135 | `(,host ,(make-int 0 (var-type to))))) 136 | (axiom (make-axiom `(,new-subgoal-0)))) 137 | (push-end axiom *node-const-axioms*)))) 138 | agg-options)) 139 | 140 | (defun transform-agg-construct (clause construct) 141 | nil) 142 | 143 | (defun agg-transformer () 144 | (do-rules (:clause clause :body body) 145 | (do-agg-constructs body (:agg-construct c) 146 | (transform-agg-construct clause c))) 147 | (do-definitions (:name name :types typs) 148 | (check-aggregates name typs))) 149 | -------------------------------------------------------------------------------- /ast.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (defclass ast () 4 | ((definitions 5 | :initarg :definitions 6 | :initform (error "missing definitions.") 7 | :accessor definitions) 8 | (externs 9 | :initarg :externs 10 | :initform (error "missing externs.") 11 | :accessor externs) 12 | (clauses 13 | :initarg :clauses 14 | :initform (error "missing clauses.") 15 | :accessor clauses) 16 | (functions 17 | :initarg :functions 18 | :initform (error "missing functions.") 19 | :accessor functions) 20 | (nodes 21 | :initarg :nodes 22 | :initform (error "missing nodes.") 23 | :accessor nodes) 24 | (directives 25 | :initarg :directives 26 | :initform (error "missing directives.") 27 | :accessor directives) 28 | (consts 29 | :initarg :consts 30 | :initform (error "missing consts.") 31 | :accessor consts) 32 | (all-axioms 33 | :initarg :all-axioms 34 | :initform (error "missing all axioms.") 35 | :accessor all-axioms) 36 | (node-const-axioms 37 | :initarg :node-const-axioms 38 | :initform nil 39 | :accessor node-const-axioms) 40 | (node-var-axioms 41 | :initarg :node-var-axioms 42 | :initform nil 43 | :accessor node-var-axioms) 44 | (thread-var-axioms 45 | :initarg :thread-var-axioms 46 | :initform nil 47 | :accessor thread-var-axioms) 48 | (thread-const-axioms 49 | :initarg :thread-const-axioms 50 | :initform nil 51 | :accessor thread-const-axioms) 52 | (exported-predicates 53 | :initarg :exported-predicates 54 | :initform (error "missing exported predicates.") 55 | :accessor exported-predicates) 56 | (imported-predicates 57 | :initarg :imported-predicates 58 | :initform (error "missing imported predicates.") 59 | :accessor imported-predicates) 60 | (ast-has-thread-facts-p 61 | :initarg :ast-has-thread-facts-p 62 | :initform nil 63 | :accessor ast-has-thread-facts-p) 64 | (args-needed 65 | :initarg :args-needed 66 | :initform (error "missing args-needed.") 67 | :accessor args-needed))) 68 | 69 | (defun make-ast (defs externs clauses axioms funs nodes directives consts exported-predicates imported-predicates args-needed) 70 | (do-definitions-list defs (:definition def :types typs) 71 | (when (type-thread-p (first typs)) 72 | (definition-set-thread def))) 73 | (make-instance 'ast 74 | :definitions defs 75 | :externs externs 76 | :clauses clauses 77 | :all-axioms axioms 78 | :functions funs 79 | :nodes nodes 80 | :directives directives 81 | :consts consts 82 | :exported-predicates exported-predicates 83 | :imported-predicates imported-predicates 84 | :args-needed args-needed)) 85 | 86 | (defun merge-asts (ast1 ast2) 87 | "Merges two ASTs together. Note that ast1 is modified." 88 | (make-instance 'ast 89 | :definitions (nconc (definitions ast1) (definitions ast2)) 90 | :externs (nconc (externs ast1) (externs ast2)) 91 | :clauses (nconc (clauses ast1) (clauses ast2)) 92 | :all-axioms (nconc (all-axioms ast1) (all-axioms ast2)) 93 | :functions (nconc (functions ast1) (functions ast2)) 94 | :nodes (union (nodes ast1) (nodes ast2)) 95 | :directives (union (directives ast1) (directives ast2)) 96 | :consts (append (consts ast1) (consts ast2)) 97 | :exported-predicates (append (exported-predicates ast1) (exported-predicates ast2)) 98 | :imported-predicates (append (imported-predicates ast1) (imported-predicates ast2)) 99 | :args-needed (max (args-needed ast1) (args-needed ast2)))) 100 | 101 | (defun ast-prepare (ast seen-subgoals) 102 | (let ((threads (some #'definition-is-thread-p (definitions ast)))) 103 | (ast-add-base-tuples ast threads seen-subgoals) 104 | (multiple-value-bind (const-axioms var-axioms) (split-mult-return #'is-constant-axiom-p (all-axioms ast)) 105 | (multiple-value-bind (node-const-axioms thread-const-axioms) 106 | (split-mult-return #L(is-node-axiom-p !1 (definitions ast)) const-axioms) 107 | (multiple-value-bind (node-var-axioms thread-var-axioms) 108 | (split-mult-return #L(is-node-axiom-p !1 (definitions ast)) var-axioms) 109 | (setf (node-var-axioms ast) node-var-axioms 110 | (node-const-axioms ast) node-const-axioms 111 | (thread-var-axioms ast) thread-var-axioms 112 | (thread-const-axioms ast) thread-const-axioms 113 | (ast-has-thread-facts-p ast) threads)))))) 114 | 115 | (defun ast-remove-unneeded-definitions (ast) 116 | (setf *definitions* (remove-if #'definition-is-instruction-p *definitions*))) 117 | 118 | ;;;;;;;;;;;;;;;;;;; 119 | ;; Clauses 120 | ;;;;;;;;;;;;;;;;;;; 121 | 122 | (defun make-clause (perm conc &rest options) `(:clause ,perm ,conc ,options)) 123 | (defun make-axiom (conc &rest options) (make-clause nil conc options)) 124 | (defun clause-p (clause) (tagged-p clause :clause)) 125 | (defun clause-head (clause) (third clause)) 126 | (defun clause-body (clause) (second clause)) 127 | (defun set-clause-body (clause new-body) 128 | (setf (second clause) new-body)) 129 | (defsetf clause-body set-clause-body) 130 | (defun set-clause-head (clause new-head) 131 | (setf (third clause) new-head)) 132 | (defsetf clause-head set-clause-head) 133 | 134 | (defun clause-options (clause) (fourth clause)) 135 | (defun clause-add-option (clause opt) (push opt (fourth clause))) 136 | (defun clause-has-tagged-option-p (clause opt) (option-has-tag-p (clause-options clause) opt)) 137 | (defun clause-get-tagged-option (clause opt) 138 | (let ((res (find-if #L(tagged-p !1 opt) (clause-options clause)))) 139 | (when res 140 | (rest res)))) 141 | (defun clause-get-all-tagged-options (clause opt) 142 | (mapfilter #'rest #L(tagged-p !1 opt) (clause-options clause))) 143 | (defun clause-add-tagged-option (clause opt &rest rest) 144 | (clause-add-option clause `(,opt ,@rest))) 145 | (defun clause-get-remote-dest (clause) 146 | (first (clause-get-tagged-option clause :route))) 147 | (defun clause-is-remote-p (clause) (clause-has-tagged-option-p clause :route)) 148 | (defun clause-has-delete-p (clause) (clause-has-tagged-option-p clause :delete)) 149 | (defun clause-get-all-deletes (clause) 150 | (clause-get-all-tagged-options clause :delete)) 151 | (defun clause-get-delete (clause name) 152 | (find-if #L(string-equal (first !1) name) (clause-get-all-deletes clause))) 153 | (defun clause-add-delete (clause name args) 154 | (clause-add-tagged-option clause :delete name args)) 155 | (defun clause-add-min (clause var) 156 | (clause-add-tagged-option clause :min var)) 157 | (defun clause-has-min-p (clause) 158 | (clause-has-tagged-option-p clause :min)) 159 | (defun clause-get-min-variable (clause) 160 | (first (clause-get-tagged-option clause :min))) 161 | (defun clause-add-random (clause var) 162 | (clause-add-tagged-option clause :random var)) 163 | (defun clause-has-random-p (clause) 164 | (clause-has-tagged-option-p clause :random)) 165 | (defun clause-get-random-variable (clause) 166 | (first (clause-get-tagged-option clause :random))) 167 | (defun clause-add-id (clause id) 168 | (clause-add-tagged-option clause :id id)) 169 | (defun clause-get-id (clause) 170 | (first (clause-get-tagged-option clause :id))) 171 | (defun clause-set-persistent (clause) 172 | (clause-add-tagged-option clause :persistent)) 173 | (defun clause-is-persistent-p (clause) 174 | (clause-has-tagged-option-p clause :persistent)) 175 | (defun clause-head-is-recursive-p (clause-head) 176 | (and (not (null clause-head)) (every #'clause-p clause-head))) 177 | (defun delete-option-args (delete-opt) (second delete-opt)) 178 | (defun delete-option-name (delete-opt) (first delete-opt)) 179 | 180 | (defun is-axiom-p (clause) 181 | (and (null (find-if #'subgoal-p (clause-body clause))) 182 | (null (find-if #'agg-construct-p (clause-body clause))))) 183 | 184 | (defun is-constant-axiom-p (clause) 185 | (and (null (get-subgoals (clause-body clause))) 186 | (every #'subgoal-has-arbitrary-node-p (get-subgoals (clause-head clause))))) 187 | 188 | (defun is-node-axiom-p (clause defs) 189 | (every #L(let ((def (lookup-subgoal-definition !1 defs))) 190 | (assert def (!1) "Could not retrieve definition of ~a." !1) 191 | (with-definition def (:types types) 192 | (let ((typ (first types))) 193 | (or (type-node-p typ) (type-addr-p typ))))) 194 | (get-subgoals (clause-head clause)))) 195 | 196 | (defun subgoal-has-arbitrary-node-p (sub) 197 | (with-subgoal sub (:args args) 198 | (const-p (first args)))) 199 | 200 | ;;;;;;;;;;;;;;;;;;; 201 | ;; CONSTS 202 | ;;;;;;;;;;;;;;;;;;; 203 | 204 | (defun make-constant (name expr &optional type) `(:constant ,name ,expr ,type)) 205 | (defun constant-p (c) (tagged-p c :constant)) 206 | (defun constant-name (c) (second c)) 207 | (defun constant-expr (c) (third c)) 208 | (defun constant-type (c) (fourth c)) 209 | (defun set-constant-expr (c expr) 210 | (setf (third c) expr)) 211 | (defsetf constant-expr set-constant-expr) 212 | 213 | (defun set-constant-type (c newt) 214 | (setf (fourth c) newt)) 215 | (defsetf constant-type set-constant-type) 216 | 217 | (defun lookup-const (name) 218 | (find-if #L(string-equal name (constant-name !1)) *consts*)) 219 | 220 | (defun constant-cons-p (expr) 221 | (if (nil-p expr) 222 | t 223 | (let ((head (cons-head expr)) 224 | (tail (cons-tail expr))) 225 | (and (literal-p head) 226 | (constant-cons-p tail))))) 227 | -------------------------------------------------------------------------------- /cl-meld.asd: -------------------------------------------------------------------------------- 1 | (defpackage #:meld-asd 2 | (:use :cl :asdf)) 3 | 4 | (in-package :meld-asd) 5 | 6 | (defsystem cl-meld 7 | :name "meld" 8 | :version "0.0" 9 | :author "Flavio Cruz" 10 | :description "Meld compiler" 11 | :depends-on (:cl-lex :yacc :arnesi :alexandria :flexi-streams :ieee-floats :cl-csv) 12 | :components ( (:file "conf" 13 | :depends-on ("package")) 14 | (:file "external" 15 | :depends-on ("package" 16 | "util" 17 | "manip")) 18 | (:file "parser" 19 | :depends-on ("package" 20 | "macros" 21 | "manip" 22 | "conf" 23 | "directives")) 24 | (:file "directives" 25 | :depends-on ("package" 26 | "macros" 27 | "util" 28 | "conf" 29 | "context")) 30 | (:file "util" 31 | :depends-on ("package" 32 | "macros")) 33 | (:file "manip" 34 | :depends-on ("package" 35 | "util" 36 | "macros" 37 | "ast" 38 | "context")) 39 | (:file "search" 40 | :depends-on ("package" 41 | "util" 42 | "manip" 43 | "macros")) 44 | (:file "transform" 45 | :depends-on ("package" 46 | "util" 47 | "manip" 48 | "macros" 49 | "search")) 50 | (:file "types" 51 | :depends-on ("package" 52 | "util" 53 | "context" 54 | "macros")) 55 | (:file "macros" 56 | :depends-on ("package")) 57 | (:file "ast" 58 | :depends-on ("context" 59 | "util" 60 | "types")) 61 | (:file "context" 62 | :depends-on ("package")) 63 | (:file "typecheck" 64 | :depends-on ("package" 65 | "manip" 66 | "macros" 67 | "types" 68 | "aggtransformer")) 69 | (:file "localize" 70 | :depends-on ("package" 71 | "search" 72 | "ast" 73 | "context" 74 | "macros" 75 | "transform")) 76 | (:file "vm" 77 | :depends-on ("util" 78 | "macros" 79 | "manip")) 80 | (:file "compile" 81 | :depends-on ("package" 82 | "manip" 83 | "macros" 84 | "vm")) 85 | (:file "meld" 86 | :depends-on ("parser" 87 | "localize" 88 | "topology" 89 | "compile" 90 | "models/parallel" 91 | "optimize" 92 | "typecheck" 93 | "output" 94 | "bt2c" 95 | "context" 96 | "stratification")) 97 | (:file "stratification" 98 | :depends-on ("manip" 99 | "util" 100 | "macros" 101 | "localize" 102 | "typecheck" 103 | "conf" 104 | "directives" 105 | "context")) 106 | (:file "models/base" 107 | :depends-on ("manip" 108 | "macros" 109 | "util")) 110 | (:file "models/parallel" 111 | :depends-on ("models/base")) 112 | (:file "output" 113 | :depends-on ("manip" 114 | "util" 115 | "compile" 116 | "vm" 117 | "topology" 118 | "localize" 119 | "stratification" 120 | "external" 121 | "models/base")) 122 | (:file "bt2c" 123 | :depends-on ("output" 124 | "package")) 125 | (:file "optimize" 126 | :depends-on ("manip" 127 | "util" 128 | "macros" 129 | "vm" 130 | "compile")) 131 | (:file "compare" 132 | :depends-on ("manip" 133 | "util" 134 | "macros" 135 | "ast")) 136 | (:file "aggtransformer" 137 | :depends-on ("manip" 138 | "util" 139 | "macros" 140 | "ast")) 141 | (:file "topology" 142 | :depends-on ("manip" 143 | "util" 144 | "conf")) 145 | (:file "snap-stanford" 146 | :depends-on ("util" 147 | "topology")) 148 | (:file "print" 149 | :depends-on ("package" 150 | "manip" 151 | "macros")) 152 | (:file "package"))) 153 | 154 | -------------------------------------------------------------------------------- /compare.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (defmacro expr-cond (&rest rest) 4 | `(cond 5 | ,@(loop for (item . code) in rest 6 | collect (if (eq item t) 7 | `(t ,@code) 8 | `((,item a) (when (,item b) ,@code)))))) 9 | 10 | (defun expr-eq-p (a b) 11 | "Compares expression a and expression b and returns T if they are equal, nil otherwise." 12 | (expr-cond 13 | (int-p 14 | (eq (int-val a) 15 | (int-val b))) 16 | (var-p (var-eq-p a b)) 17 | (float-p (eq (float-val a) (float-val b))) 18 | (host-id-p t) 19 | (nil-p t) 20 | (world-p t) 21 | (addr-p (eq (addr-num a) (addr-num b))) 22 | (call-p (and (string-equal (call-name a) (call-name b)) 23 | (every #L(expr-eq-p !1 !2) (call-args a) (call-args b)))) 24 | (cons-p (and (expr-eq-p (cons-head a) (cons-head b)) 25 | (expr-eq-p (cons-tail a) (cons-tail b)))) 26 | (head-p (expr-eq-p (head-list a) (head-list b))) 27 | (tail-p (expr-eq-p (tail-list a) (tail-list b))) 28 | (not-p (expr-eq-p (not-expr a) (not-expr b))) 29 | (test-nil-p (expr-eq-p (test-nil-expr a) (test-nil-expr b))) 30 | (convert-float-p (expr-eq-p (convert-float-expr a) (convert-float-expr b))) 31 | (op-p (and (eq (op-op a) (op-op b)) 32 | (expr-eq-p (op-op1 a) (op-op1 b)) 33 | (expr-eq-p (op-op2 a) (op-op2 b)))) 34 | (t (error 'expr-invalid-error 35 | :text (tostring "Invalid expression type for expr-eq-p: ~a" a))))) -------------------------------------------------------------------------------- /conf.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (defparameter *use-optimizations* t) 4 | (defparameter *use-stratification* nil) 5 | 6 | ;(defparameter *ordering-type* :random) 7 | (defparameter *ordering-type* :breadth) 8 | ;(defparameter *ordering-type* :naive) 9 | ;(defparameter *ordering-type* :in-file) 10 | 11 | ;; Enable index directives. 12 | (defparameter *use-index* t) 13 | ;; Enable compact directives. 14 | (defparameter *use-compact* t) 15 | -------------------------------------------------------------------------------- /context.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :cl-meld) 3 | 4 | (defparameter *file* nil "Compiled file path.") 5 | (defparameter *ast* nil "Abstract Syntax Tree.") 6 | (defparameter *code* nil "Virtual Machine instructions.") 7 | (defparameter *code-rules* nil "Virtual Machine instructions for each rule.") 8 | (defparameter *has-exists-p* nil "If any exists construct exists in the program.") 9 | (defparameter *data-input* nil) 10 | (defparameter *node-types* nil "Available node subtypes.") 11 | 12 | (define-symbol-macro *definitions* (definitions *ast*)) 13 | (define-symbol-macro *node-definitions* *definitions*) 14 | (define-symbol-macro *clauses* (clauses *ast*)) 15 | (define-symbol-macro *node-var-axioms* (node-var-axioms *ast*)) 16 | (define-symbol-macro *thread-var-axioms* (thread-var-axioms *ast*)) 17 | (define-symbol-macro *node-const-axioms* (node-const-axioms *ast*)) 18 | (define-symbol-macro *thread-const-axioms* (thread-const-axioms *ast*)) 19 | (define-symbol-macro *nodes* (nodes *ast*)) 20 | (define-symbol-macro *externs* (externs *ast*)) 21 | (define-symbol-macro *functions* (functions *ast*)) 22 | (define-symbol-macro *directives* (directives *ast*)) 23 | (define-symbol-macro *consts* (consts *ast*)) 24 | (define-symbol-macro *processes* (processes *code*)) 25 | (define-symbol-macro *consts-code* (consts *code*)) 26 | (define-symbol-macro *function-code* (functions *code*)) 27 | (define-symbol-macro *exported-predicates* (exported-predicates *ast*)) 28 | (define-symbol-macro *imported-predicates* (imported-predicates *ast*)) 29 | 30 | (defun set-abstract-syntax-tree (ast) (setf *ast* ast)) 31 | -------------------------------------------------------------------------------- /count.sh: -------------------------------------------------------------------------------- 1 | 2 | find . -name '*.lisp' | xargs wc -l 3 | -------------------------------------------------------------------------------- /directives.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (defun make-allocator (typ) 4 | (let* ((remain1 (subseq typ 1)) 5 | (remain (subseq remain1 0 (1- (length remain1))))) 6 | (let ((vec (split-string remain :delimiterp #'(lambda (x) (char= x #\Space)))) 7 | opts) 8 | (if (find-if #'(lambda (a) (string-equal a "basic")) vec) 9 | (push :basic opts)) 10 | `(:allocator ,opts)))) 11 | (defun allocator-has-option-p (alloc opt) 12 | (find opt (second alloc))) 13 | (defun find-allocator () 14 | (find-if #L(tagged-p !1 :allocator) *directives*)) 15 | 16 | (defun make-index (name field) `(:index ,name ,field)) 17 | (defun index-name (x) (second x)) 18 | (defun index-field (x) (third x)) 19 | (defun index-p (x) (tagged-p x :index)) 20 | (defun find-index-name (name) 21 | (when *use-index* 22 | (find-if #L(and (index-p !1) (string-equal name (index-name !1))) *directives*))) 23 | 24 | (defun make-compact (name) `(:compact ,name)) 25 | (defun compact-name (x) (second x)) 26 | (defun compact-p (x) (tagged-p x :compact)) 27 | (defun find-compact-name (name) 28 | (when *use-compact* 29 | (or (let ((def (lookup-definition name))) 30 | (definition-is-compact-p def)) 31 | (find-if #L(and (compact-p !1) (string-equal name (compact-name !1))) *directives*)))) 32 | 33 | (defun make-data-input (template file &optional args) `(:data-input ,template ,file ,args)) 34 | (defun data-input-template (x) (second x)) 35 | (defun data-input-file (x) (third x)) 36 | (defun data-input-args (x) (fourth x)) 37 | (defun data-input-p (x) (tagged-p x :data-input)) 38 | (defun find-data-input () (find-if #L(data-input-p !1) *directives*)) 39 | 40 | (defun make-descending-priority (a b) `(:prio ,a ,b)) 41 | (defun make-ascending-priority (a b) `(:prio ,b ,a)) 42 | 43 | (defun priority-p (x) (tagged-p x :prio)) 44 | (defun priority-left (x) (second x)) 45 | (defun priority-right (x) (third x)) 46 | 47 | (defun make-initial-priority (num) `(:initial-prio ,num)) 48 | (defun initial-priority-value (p) (second p)) 49 | (defun initial-priority-p (p) (tagged-p p :initial-prio)) 50 | 51 | (defun make-default-priority (num) `(:default-prio ,num)) 52 | (defun default-priority-p (p) (tagged-p p :default-prio)) 53 | (defun default-priority-value (p) (second p)) 54 | 55 | (defun make-no-priority (num) `(:no-priority ,num)) 56 | (defun no-priority-p (p) (tagged-p p :no-priority)) 57 | (defun no-priority-value (p) (second p)) 58 | 59 | (defun make-priority-no-initial () `(:no-initial-priorities)) 60 | (defun priority-no-initial-p (p) (tagged-p p :no-initial-priorities)) 61 | 62 | (defun make-priority-order (asc-desc) `(:priority-order ,asc-desc)) 63 | (defun priority-order (x) (second x)) 64 | (defun priority-order-p (x) (tagged-p x :priority-order)) 65 | 66 | (defun make-priority-static () `(:priority-static)) 67 | (defun priority-static-p (x) (tagged-p x :priority-static)) 68 | 69 | (defun make-priority-cluster (typ) `(:priority-cluster ,typ)) 70 | (defun priority-cluster-type (x) (second x)) 71 | (defun priority-cluster-p (x) (tagged-p x :priority-cluster)) 72 | 73 | (defun all-start-nodes (priorities) 74 | (remove-duplicates (mapcar #'priority-left priorities) :test #'string-equal)) 75 | (defun all-end-nodes (priorities) 76 | (remove-duplicates (mapcar #'priority-right priorities) :test #'string-equal)) 77 | 78 | (defun select-start-nodes (priorities) 79 | (set-difference (all-start-nodes priorities) (all-end-nodes priorities) :test #'string-equal)) 80 | 81 | (defun remove-all-start-nodes (priorities start-nodes) 82 | (split-mult-return #'(lambda (prio) 83 | (let* ((what (priority-left prio)) 84 | (x (find what start-nodes :test #'string-equal))) 85 | (if x t nil))) 86 | priorities)) 87 | 88 | (defun get-priority-static () (find-if #'priority-static-p *directives*)) 89 | 90 | (defun get-priority-order () 91 | "Returns priority ordering for the program." 92 | (let ((order (find-if #'priority-order-p *directives*))) 93 | (if order 94 | (priority-order order) 95 | :desc))) 96 | 97 | (defun get-default-priority () 98 | "Returns default priority for nodes of the program." 99 | (let ((found (find-if #'default-priority-p *directives*))) 100 | (if found 101 | (default-priority-value found) 102 | (case (get-priority-order) 103 | (:asc most-positive-double-float) 104 | (:desc most-negative-double-float))))) 105 | 106 | (defun get-initial-priority () 107 | "Returns initial priority for nodes of the program." 108 | (let ((found (find-if #'initial-priority-p *directives*))) 109 | (if found 110 | (initial-priority-value found) 111 | (let ((no-initial (find-if #'priority-no-initial-p *directives*))) 112 | (if no-initial 113 | (get-default-priority) 114 | (case (get-priority-order) 115 | (:asc most-negative-double-float) 116 | (:desc most-positive-double-float))))))) 117 | 118 | (defun get-no-priority-value () 119 | "Returns the value that represents base priorities." 120 | (let ((found (find-if #'no-priority-p *directives*))) 121 | (if found 122 | (no-priority-value found) 123 | (case (get-priority-order) 124 | (:asc most-positive-double-float) 125 | (:desc most-negative-double-float))))) 126 | 127 | (defun assign-priorities (base priorities) 128 | "Using the start priority 'base', it assigns increasing priorities taking into 129 | account the dependencies between predicates." 130 | (let ((start-nodes (select-start-nodes priorities))) 131 | (cond 132 | ((null start-nodes) nil) 133 | (t 134 | (multiple-value-bind (removed remaining-nodes) 135 | (remove-all-start-nodes priorities start-nodes) 136 | (let* ((end-nodes (all-end-nodes removed)) 137 | (disappearing-nodes (set-difference end-nodes (all-start-nodes remaining-nodes) :test #'string-equal)) 138 | (result (mapcar #L(cons !1 base) start-nodes))) 139 | (append result 140 | (append (mapcar #L(cons !1 (1+ base)) disappearing-nodes) 141 | (if (null remaining-nodes) nil (assign-priorities (1+ base) remaining-nodes)))))))))) 142 | 143 | (defun find-priorities () 144 | "Takes the *ast* code and finds new priorities from the comprehensions and aggregates." 145 | (return-from find-priorities nil) 146 | (do-rules (:head head :body body) 147 | (do-comprehensions head (:left left) 148 | (do-subgoals left (:name name1) 149 | (do-subgoals body (:name name2) 150 | (push-end (make-descending-priority name1 name2) *directives*)))) 151 | (do-agg-constructs head (:body aggbody) 152 | (do-subgoals aggbody (:name name1) 153 | (do-subgoals body (:name name2) 154 | (push-end (make-descending-priority name1 name2) *directives*)))))) 155 | 156 | (defgeneric data-input-node-axioms (data n)) 157 | (defgeneric data-input-nodes (data)) 158 | -------------------------------------------------------------------------------- /external.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (define-condition external-invalid-error (error) 4 | ((text :initarg :text :reader text))) 5 | 6 | (defparameter *external-functions* (make-hash-table :test #'equal)) 7 | (defparameter *external-functions-counter* 0) 8 | 9 | (defun lookup-custom-external-function (name) 10 | (find-if (lambda (x) (string-equal name (extern-name x))) *externs*)) 11 | 12 | (defun lookup-custom-external-function-id (name) 13 | (extern-id (lookup-custom-external-function name))) 14 | 15 | (defun lookup-standard-external-function (name) 16 | (multiple-value-bind (extern found-p) (gethash name *external-functions*) 17 | (if found-p 18 | extern))) 19 | 20 | (defun lookup-external-definition (name) 21 | ;; lookup pre-defined externals first 22 | (multiple-value-bind (extern found-p) (gethash name *external-functions*) 23 | (unless found-p 24 | ;; if not, look for user defined 25 | (let ((item (lookup-custom-external-function name))) 26 | (when item 27 | (setf found-p t 28 | extern item)))) 29 | (unless found-p 30 | (error 'external-invalid-error :text (tostring "invalid external function: ~a" name))) 31 | extern)) 32 | 33 | (defun lookup-external-function-id (name) 34 | (extern-id (lookup-external-definition name))) 35 | 36 | (defmacro define-external-function (name ret-type types &key (poly-p nil)) 37 | `(progn 38 | (setf (gethash ,name *external-functions*) (make-extern ,name ,ret-type ,types *external-functions-counter* ,poly-p)) 39 | (incf *external-functions-counter*))) 40 | 41 | (define-external-function "sigmoid" :type-float '(:type-float)) 42 | (define-external-function "randint" :type-int '(:type-int)) 43 | (define-external-function "normalize" '(:type-list :type-float) '((:type-list :type-float))) 44 | (define-external-function "damp" '(:type-list :type-float) '((:type-list :type-float) (:type-list :type-float) :type-float)) 45 | (define-external-function "divide" '(:type-list :type-float) '((:type-list :type-float) (:type-list :type-float))) 46 | (define-external-function "convolve" '(:type-list :type-float) '((:type-list :type-float) (:type-list :type-float))) 47 | (define-external-function "addfloatlists" '(:type-list :type-float) '((:type-list :type-float) (:type-list :type-float))) 48 | (define-external-function "intlistdiff" '(:type-list :type-int) '((:type-list :type-int) (:type-list :type-int))) 49 | (define-external-function "lnth" :all '((:type-list :all) :type-int)) 50 | (define-external-function "concatenate" :type-string '(:type-string :type-string)) 51 | (define-external-function "str2float" :type-float '(:type-string)) 52 | (define-external-function "str2int" :type-int '(:type-string)) 53 | (define-external-function "lremove" '(:type-list :all) '((:type-list :all) :all) :poly-p t) 54 | (define-external-function "wastetime" :type-int '(:type-int)) 55 | (define-external-function "truncate" :type-float '(:type-float :type-int)) 56 | (define-external-function "float2int" :type-int '(:type-float)) 57 | (define-external-function "int2str" :type-string '(:type-int)) 58 | (define-external-function "float2str" :type-string '(:type-float)) 59 | (define-external-function "intlistsub" '(:type-list :type-int) '((:type-list :type-int) :type-int :type-int)) 60 | (define-external-function "str2intlist" '(:type-list :type-int) '(:type-string)) 61 | (define-external-function "filecountwords" :type-int '(:type-string :type-int)) 62 | (define-external-function "residual" :type-float '((:type-list :type-float) (:type-list :type-float))) 63 | (define-external-function "llength" :type-int '((:type-list :all))) 64 | (define-external-function "lappend" '(:type-list :all) '((:type-list :all) (:type-list :all)) :poly-p t) 65 | (define-external-function "priority" :type-float '(:type-addr)) 66 | (define-external-function "lreverse" '(:type-list :all) '((:type-list :all)) :poly-p t) 67 | (define-external-function "llast" :all '((:type-list :all))) 68 | (define-external-function "cpu-id" :type-thread '(:type-addr)) 69 | (define-external-function "node2int" :type-int '(:type-addr)) 70 | (define-external-function "intpower" :type-int '(:type-int :type-int)) 71 | (define-external-function "lsort" '(:type-list :all) '((:type-list :all)) :poly-p t) 72 | (define-external-function "lremoveduplicates" '(:type-list :all) '((:type-list :all)) :poly-p t) 73 | (define-external-function "degeneratevector" '(:type-list :type-int) '(:type-int :type-int)) 74 | (define-external-function "demergemessages" '(:type-list :type-int) '((:type-list :type-int) (:type-list :type-int))) 75 | (define-external-function "intlistequal" :type-int '((:type-list :type-int) (:type-list :type-int))) 76 | (define-external-function "addfloatstructs" '(:type-struct :all) '((:type-struct :all) (:type-struct :all)) :poly-p t) 77 | (define-external-function "normalizestruct" '(:type-struct :all) '((:type-struct :all)) :poly-p t) 78 | (define-external-function "dampstruct" '(:type-struct :all) '((:type-struct :all) (:type-struct :all) :type-float) :poly-p t) 79 | (define-external-function "residualstruct" :type-float '((:type-struct :all) (:type-struct :all)) :poly-p t) 80 | (define-external-function "dividestruct" '(:type-struct :all) '((:type-struct :all) (:type-struct :all)) :poly-p t) 81 | (define-external-function "convolvestruct" '(:type-struct :all) `((:type-struct ,(loop for i from 1 upto 25 collect :type-float)) (:type-struct :all)) :poly-p t) 82 | (define-external-function "cpu-static" :type-int '(:type-addr)) 83 | (define-external-function "is-moving" :type-bool '(:type-addr)) 84 | (define-external-function "is-static" :type-bool '(:type-addr)) 85 | (define-external-function "partition_vertical" :type-thread '(:type-int :type-int :type-int :type-int)) 86 | (define-external-function "partition_horizontal" :type-thread '(:type-int :type-int :type-int :type-int)) 87 | (define-external-function "partition_grid" :type-thread '(:type-int :type-int :type-int :type-int)) 88 | (define-external-function "queue-size" :type-int '(:type-addr)) 89 | (define-external-function "facts-proved" :type-int '(:type-addr)) 90 | (define-external-function "facts-consumed" :type-int '(:type-addr)) 91 | (define-external-function "lcount" :type-int '((:type-list :all) :all) :poly-p t) 92 | (define-external-function "lexists" :type-bool '((:type-list :all) :all) :poly-p t) 93 | (define-external-function "lexistss" :type-bool '((:type-list :all) (:type-list :all)) :poly-p t) 94 | (define-external-function "queens_violation" :type-bool '(:type-int (:type-list :type-int))) 95 | (define-external-function "minimax_score" :type-int '((:type-list :type-int) :type-int :type-int)) 96 | (define-external-function "minimax_points" :type-int '((:type-list :type-int) :type-int)) 97 | (define-external-function "array_init" '(:type-array :all) '(:type-int :all) :poly-p t) 98 | (define-external-function "array_get" :all '((:type-array :all) :type-int)) 99 | (define-external-function "array_set" '(:type-array :all) '((:type-array :all) :type-int :all) :poly-p t) 100 | (define-external-function "array_add" '(:type-array :all) '((:type-array :all) :all) :poly-p t) 101 | (define-external-function "array_from_list" '(:type-array :all) '((:type-list :all)) :poly-p t) 102 | (define-external-function "array_size" :type-int '((:type-array :all))) 103 | (define-external-function "minimax_score2" :type-int '((:type-array :type-int) :type-int :type-int)) 104 | (define-external-function "minimax_points2" :type-int '((:type-array :type-int) :type-int)) 105 | (define-external-function "fabs" :type-float '(:type-float)) (define-external-function "set_size" :type-int '((:type-set :all))) 106 | (define-external-function "set_exists" :type-bool '((:type-set :all) :all) :poly-p t) 107 | (define-external-function "set_add" '(:type-set :all) '((:type-set :all) :all) :poly-p t) 108 | (define-external-function "set_from_list" '(:type-set :all) '((:type-list :all)) :poly-p t) 109 | (define-external-function "array_exists" :type-bool '((:type-array :all) :all) :poly-p t) 110 | (define-external-function "ltake" '(:type-list :all) '((:type-list :all) :type-int)) 111 | -------------------------------------------------------------------------------- /install.lisp: -------------------------------------------------------------------------------- 1 | ;; installs required quickload packages. 2 | 3 | (ql:quickload "yacc") 4 | (ql:quickload "cl-ppcre") 5 | (ql:quickload "cl-lex") 6 | (ql:quickload "arnesi") 7 | (ql:quickload "alexandria") 8 | (ql:quickload "flexi-streams") 9 | (ql:quickload "cl-csv") 10 | (ql:quickload "ieee-floats") 11 | -------------------------------------------------------------------------------- /load.lisp: -------------------------------------------------------------------------------- 1 | 2 | (require 'asdf) 3 | (push (truename ".") asdf:*central-registry*) 4 | (ql:quickload "cl-meld") 5 | -------------------------------------------------------------------------------- /localize.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (define-condition localize-invalid-error (error) 4 | ((text :initarg :text :reader text))) 5 | 6 | (defvar *route-facts-to-invert* nil) 7 | (defun add-route-fact-to-invert (fact) 8 | (push-dunion fact *route-facts-to-invert*)) 9 | 10 | (defun get-first-arg (subgoal) 11 | (first (subgoal-args subgoal))) 12 | (defun get-second-arg (subgoal) 13 | (second (subgoal-args subgoal))) 14 | 15 | (defun get-paths (subgoals routes) 16 | (filter #L(has-test-elem-p routes (subgoal-name !1) #'string-equal) (get-subgoals subgoals))) 17 | 18 | (defun equal-to-any-home (arg homes) 19 | (some #L(var-eq-p arg !1) homes)) 20 | (defun select-subgoals-by-home (subgoals home-vars) 21 | (filter #L(equal-to-any-home (get-first-arg !1) home-vars) (get-subgoals subgoals))) 22 | 23 | (defun generate-args (n typs) 24 | (mapcar #L(make-var (concatenate 'string "X" (write-to-string !2)) !1) typs (enumerate 0 (1- n)))) 25 | (defun generate-inverse-name (name) 26 | (concatenate 'string "___" (reverse name))) 27 | (defun swap-first-two-args (args) 28 | `(,(second args) ,(first args) ,@(rest (rest args)))) 29 | (defun change-first-arg (args first) 30 | `(,first ,@(rest args))) 31 | 32 | (defparameter *name-counter* 0) 33 | (defun generate-mangled-name (&optional (prefix "mangledname")) 34 | (with-output-to-string (a) (format a "__~a~a" prefix (incf *name-counter*)))) 35 | 36 | (defun create-inverse-non-fact-route-definition (route new-name) 37 | (let* ((old-definition (lookup-definition-types route)) 38 | (new-definition (make-definition new-name old-definition (list :route `(:reverse-route ,route))))) 39 | (push-end new-definition *definitions*) 40 | new-definition)) 41 | 42 | (defun create-inverse-non-fact-route (route new-name new-definition) 43 | (let* ((typs (definition-arg-types (definition-types new-definition))) 44 | (args (generate-args (length typs) typs)) 45 | (sub (make-subgoal new-name 46 | (swap-first-two-args args))) 47 | (new-clause (make-clause `(,(make-subgoal route args)) 48 | `(,sub) 49 | `(:route ,(second args))))) 50 | (subgoal-add-route sub (second args)) 51 | (push new-clause *clauses*))) 52 | 53 | (defun add-inverse-route-facts (route new-name) 54 | (with-ret to-ret 55 | (do-node-var-axioms (:head head :body body) 56 | (do-subgoals head (:name name :args args) 57 | (if (equal route name) 58 | (let* ((reverse-host (second args)) 59 | (host-var (first args)) 60 | (constraint-expr (first (find-assignment-constraints-expr body host-var))) 61 | (real-host (op-op2 constraint-expr)) 62 | (remain-args (drop-first-n args 2)) 63 | (new-clause (make-clause nil `(,(make-subgoal new-name `(,reverse-host ,real-host ,@remain-args)))))) 64 | (add-variable-head-clause new-clause) 65 | (push new-clause to-ret))))))) 66 | 67 | (defun create-inverse-routes () 68 | (dolist (route *route-facts-to-invert*) 69 | (let* ((new-name (generate-inverse-name route)) 70 | (new-definition (create-inverse-non-fact-route-definition route new-name))) 71 | (if (is-fact-p route) 72 | (let ((new-ones (add-inverse-route-facts route new-name))) 73 | (if new-ones 74 | (setf *node-const-axioms* (append new-ones *node-const-axioms*)) 75 | (create-inverse-non-fact-route route new-name new-definition))) 76 | (create-inverse-non-fact-route route new-name new-definition))))) 77 | 78 | (defun select-valid-constraints (body vars) 79 | (filter #L(subsetp (all-variable-names !1) vars) (get-constraints body))) 80 | (defun generate-inverse-subgoal (new-name to needed-vars) 81 | (make-subgoal new-name `(,to ,@needed-vars) `((:route ,to)))) 82 | 83 | (defun match-paths (sources part) #'(lambda (path) (some #L(var-eq-p !1 (funcall part path)) sources))) 84 | (defun expand-sources (sources paths) 85 | (append (mapfilter #'second (match-paths sources #'first) paths) 86 | (mapfilter #'first (match-paths sources #'second) paths))) 87 | (defun decrease-paths (sources paths) 88 | (remove-if (match-paths sources #'second) 89 | (remove-if (match-paths sources #'first) paths))) 90 | (defun host-node (head) (get-first-arg (first head))) 91 | 92 | (defun find-all-addrs-in-subgoal (subgoal) 93 | (with-subgoal subgoal (:name name :args args) 94 | (let ((types (lookup-definition-types name))) 95 | (loop for typ in (rest types) 96 | for arg in (rest args) 97 | when (or (type-addr-p typ) (type-node-p typ)) 98 | collect (list (first args) arg))))) 99 | 100 | (defun get-reachable-nodes (paths-sub host thread constraints) 101 | (when (and (not host) thread) 102 | ;; when using facts only from the thread, use only the thread 103 | (return-from get-reachable-nodes (list thread))) 104 | (when (and host thread) 105 | ;; when using facts from the thread, the thread can only reach the current node 106 | (return-from get-reachable-nodes (list host thread))) 107 | (let ((paths (mappend #L(find-all-addrs-in-subgoal !1) paths-sub)) 108 | (rm `(,host))) 109 | (loop while paths 110 | for expand = (expand-sources rm paths) 111 | do (unless expand 112 | (error 'localize-invalid-error :text (tostring "Invalid paths in clause: ~a" paths-sub))) 113 | (setf paths (decrease-paths rm paths) 114 | rm (append rm expand))) 115 | ;; find any constraint of the form var1 = var2 116 | ;; and include var2 in the return list 117 | (let ((more (loop for var in rm 118 | append (let ((es (find-assignment-constraints-expr constraints var))) 119 | (loop for e in es 120 | append (when (var-p (op-op2 e)) 121 | (list (op-op2 e)))))))) 122 | (append rm more)))) 123 | 124 | (defun variables-defined-on-body (body host &optional except) 125 | (with-ret ret 126 | (push-dunion host ret) 127 | (do-assignments body (:var var) (push-dunion var ret)) 128 | (do-subgoals body (:args args) 129 | (dolist (arg args) 130 | (when (and (var-p arg) 131 | (or (null except) 132 | (not (var-eq-p except arg)))) 133 | (push-dunion arg ret)))))) 134 | 135 | (defun variables-undefined-on-head-and-body (head body) 136 | (with-ret ret 137 | (push-dunion-all (all-variables head) ret) 138 | (do-constraints body (:expr expr) 139 | (push-dunion-all (all-variables expr) ret)) 140 | (do-assignments body (:expr expr) 141 | (push-dunion-all (all-variables expr) ret)) 142 | (do-subgoals body (:args args) 143 | (dolist (arg args) 144 | (push-dunion-all (all-variables arg) ret))))) 145 | 146 | (defun variables-undefined-head (head body host) 147 | (set-tree-difference (variables-undefined-on-head-and-body head body) (list host))) 148 | 149 | (defun get-inverse-route (route-subgoal) 150 | (make-subgoal (generate-inverse-name (subgoal-name route-subgoal)) 151 | (swap-first-two-args (subgoal-args route-subgoal)))) 152 | 153 | (defun order-variables (vars) 154 | "Sorts variables by putting integer variables before every other." 155 | (sort vars #'(lambda (var1 var2) 156 | (declare (ignore var2)) 157 | (type-int-p (expr-type var1))))) 158 | 159 | (defun any-linear-fact-p (body) 160 | (some #L(with-subgoal !1 (:name name) 161 | (let ((def (lookup-definition name))) 162 | (is-linear-p def))) 163 | (get-subgoals body))) 164 | 165 | (defun transform-thread-subgoals-list (ls thread) 166 | (do-subgoals ls (:subgoal sub :args args) 167 | (let ((first-arg (first args))) 168 | (when (var-eq-p first-arg thread) 169 | (subgoal-set-thread sub))))) 170 | 171 | (defun transform-thread-subgoals (clause thread) 172 | (with-clause clause (:body body :head head) 173 | (transform-thread-subgoals-list body thread) 174 | (transform-thread-subgoals-list head thread) 175 | (do-comprehensions head (:left left :right right) 176 | (transform-thread-subgoals-list left thread) 177 | (transform-thread-subgoals-list right thread)) 178 | (do-agg-constructs head (:body body :head head :head0 head0) 179 | (transform-thread-subgoals-list body thread) 180 | (transform-thread-subgoals-list head0 thread) 181 | (transform-thread-subgoals-list head thread)))) 182 | 183 | (defun transform-remote-subgoals (head host thread) 184 | (let ((all-transformed t)) 185 | (do-subgoals head (:args args :subgoal sub) 186 | (let ((first-arg (first args))) 187 | (cond 188 | ((var-eq-p first-arg host) 189 | (setf all-transformed nil)) 190 | ((and thread (var-eq-p thread first-arg)) 191 | (setf all-transformed nil) 192 | (subgoal-set-thread sub)) 193 | ((addr-p first-arg) 194 | (setf all-transformed nil) 195 | (subgoal-add-route sub first-arg)) 196 | (t 197 | (subgoal-add-route sub first-arg))))) 198 | (do-comprehensions head (:right right :comprehension comp) 199 | (do-subgoals right (:args args :subgoal sub) 200 | (let ((first-arg (first args))) 201 | (cond 202 | ((var-eq-p first-arg host) 203 | (setf all-transformed nil)) 204 | ((and thread (var-eq-p thread first-arg)) 205 | (subgoal-set-thread sub)) 206 | (t 207 | (subgoal-add-route sub first-arg))))) 208 | (do-conditionals right (:term1 term1 :term2 term2) 209 | (unless (transform-remote-subgoals term1 host thread) 210 | (setf all-transformed nil)) 211 | (unless (transform-remote-subgoals term2 host thread) 212 | (setf all-transformed nil)))) 213 | (do-agg-constructs head (:head head :head0 head0) 214 | (unless (transform-remote-subgoals head host thread) 215 | (setf all-transformed nil)) 216 | (unless (transform-remote-subgoals head0 host thread) 217 | (setf all-transformed nil))) 218 | (do-exists head (:var-list vars :body body) 219 | (unless (transform-remote-subgoals body host thread) 220 | (setf all-transformed nil))) 221 | (do-conditionals head (:term1 term1 :term2 term2) 222 | (unless (transform-remote-subgoals term1 host thread) 223 | (setf all-transformed nil)) 224 | (unless (transform-remote-subgoals term2 host thread) 225 | (setf all-transformed nil))) 226 | all-transformed)) 227 | 228 | (defun do-localize-one (clause from to route-subgoal remaining &optional (order 'forward)) 229 | (let* ((reachable (get-reachable-nodes remaining to nil (get-constraints (clause-body clause)))) 230 | (subgoals (select-subgoals-by-home (clause-body clause) reachable))) 231 | (unless subgoals 232 | ;; all subgoals in host node 233 | (when (transform-remote-subgoals (clause-head clause) from nil) 234 | ; every subgoal in head goes to 'from' 235 | (clause-add-option clause `(:route ,to))) 236 | (return-from do-localize-one nil)) 237 | (let* ((body (clause-body clause)) 238 | (head (clause-head clause)) 239 | (assignments (select-valid-assignments body subgoals)) 240 | (constraints (select-valid-constraints body (all-variable-names `(,@subgoals ,@assignments)))) 241 | (stripped-body (remove-all body `(,route-subgoal ,@subgoals ,@constraints ,@assignments))) 242 | (new-routing (if (eq order 'forward) (get-inverse-route route-subgoal) nil))) 243 | (cond 244 | ((and (eq order 'backward) 245 | (null stripped-body)) 246 | (add-route-fact-to-invert (subgoal-name route-subgoal)) 247 | (if (transform-remote-subgoals (clause-head clause) from nil) 248 | (clause-add-option clause `(:route ,from))) 249 | (values clause nil)) 250 | ((and (eq order 'forward) 251 | (null stripped-body)) 252 | (add-route-fact-to-invert (subgoal-name route-subgoal)) 253 | (setf stripped-body `(,new-routing ,@assignments ,@constraints ,@subgoals)) 254 | (when (transform-remote-subgoals (clause-head clause) to nil) 255 | (clause-add-option clause `(:route ,from))) 256 | (setf (clause-body clause) stripped-body) 257 | (values clause nil)) 258 | (t 259 | (let ((new-clause-body `(,@subgoals ,@assignments ,@constraints))) 260 | (when (is-route-subgoal-alone-p new-clause-body route-subgoal from) 261 | (reverse-route-subgoal-alone route-subgoal) 262 | (transform-remote-subgoals (clause-head clause) from nil) 263 | (return-from do-localize-one nil)) 264 | (when new-routing 265 | (add-route-fact-to-invert (subgoal-name route-subgoal)) 266 | (push new-routing new-clause-body) 267 | (push new-routing subgoals)) 268 | (let* ((variables-undef-head (variables-undefined-head head stripped-body from)) 269 | (variables-subgoals (variables-defined-on-body new-clause-body to)) 270 | (needed-vars (order-variables (tree-intersection variables-subgoals variables-undef-head))) 271 | (new-subgoal (generate-inverse-subgoal (generate-mangled-name) 272 | from needed-vars))) 273 | (setf (clause-body clause) (remove-unneeded-assignments `(,new-subgoal ,@stripped-body) head)) 274 | (let* ((new-clause-head `(,(copy-tree new-subgoal))) 275 | (new-clause-body (remove-unneeded-assignments new-clause-body new-clause-head))) 276 | (with-subgoal new-subgoal (:name name) 277 | (let* ((linear-facts-exist (any-linear-fact-p new-clause-body)) 278 | (linear-prop (if linear-facts-exist '(:linear) nil))) 279 | (push-end (make-definition name `(:type-addr ,@(mapcar #'expr-type needed-vars)) 280 | `(:routed-tuple ,@linear-prop)) 281 | *definitions*))) 282 | (values (make-clause new-clause-body new-clause-head `(:route ,from)) 283 | t))))))))) 284 | 285 | (defun get-direction-and-dest (host edge) 286 | (if (var-eq-p host (get-first-arg edge)) 287 | (values 'forward (get-second-arg edge)) 288 | (values 'backward (get-first-arg edge)))) 289 | 290 | (defun do-localize (host clause edges remaining) 291 | "From node HOST in clause CLAUSE localize from EDGES" 292 | (dolist (edge edges) 293 | (multiple-value-bind (order to) (get-direction-and-dest host edge) 294 | (let* ((fun (edges-equal-to to)) 295 | (new-edges (filter fun remaining)) 296 | (new-remaining (remove-if fun remaining))) 297 | (multiple-value-bind (target-clause add-to-program-p) 298 | (do-localize-one clause host to edge remaining order) 299 | (when target-clause 300 | (if add-to-program-p 301 | (push target-clause *clauses*)) 302 | (clause-set-persistent target-clause) 303 | (when new-edges 304 | (do-localize to target-clause new-edges new-remaining)))))))) 305 | 306 | (defun check-subgoal-arguments (homes clause) 307 | "Check that the clause only uses certain nodes in 'homes'" 308 | (do-subgoals clause (:args args :name name) 309 | (let ((first-arg (first args))) 310 | (cond 311 | ((var-p first-arg) 312 | (unless (some #'(lambda (h) (var-eq-p first-arg h)) homes) 313 | (error 'localize-invalid-error 314 | :text (tostring "Subgoal ~a has a bad home argument: ~a" name first-arg)))) 315 | ((addr-p first-arg)) 316 | (t 317 | (error 'localize-invalid-error :text (tostring "Subgoal ~a has a bad home argument ~a" name first-arg))))))) 318 | 319 | (defun body-shares-same-home-p (body home-argument thread) 320 | (do-subgoals body (:args args :name name) 321 | (unless (or (var-eq-p thread (first args)) (var-eq-p home-argument (first args))) 322 | (return-from body-shares-same-home-p nil))) 323 | t) 324 | 325 | (defun edges-equal-to (host) 326 | #L(or (var-eq-p host (get-first-arg !1)) (var-eq-p host (get-second-arg !1)))) 327 | 328 | (defun find-linear-body-homes (clause homes) 329 | (let ((vars1 (iterate-expr #'(lambda (x) 330 | (cond 331 | ((and (var-p x) (type-thread-p (var-type x))) x) 332 | ((and (var-p x) (or (type-node-p (var-type x)) (type-addr-p (var-type x)))) 333 | x))) clause))) 334 | (remove-duplicates (append vars1 homes) :test #'var-eq-p))) 335 | 336 | (defun localize-start (clause routes host thread) 337 | (let ((paths (get-paths (clause-body clause) routes))) 338 | (let ((home-arguments (get-reachable-nodes paths host thread (get-constraints (clause-body clause)))) 339 | same-home) 340 | (when (body-shares-same-home-p (clause-body clause) host thread) 341 | ;; When using the same home argument in the body of the rule 342 | ;; we may use all the node variables in the body 343 | (setf same-home t) 344 | (setf home-arguments (find-linear-body-homes clause home-arguments))) 345 | (localize-check-head (clause-head clause) clause home-arguments host thread) 346 | (check-subgoal-arguments home-arguments clause) 347 | (cond 348 | (same-home 349 | (when thread 350 | (transform-thread-subgoals clause thread)) 351 | (transform-remote-subgoals (clause-head clause) host thread)) 352 | (t 353 | (let* ((fun (edges-equal-to host)) 354 | (edges (filter fun paths)) 355 | (remaining (remove-if fun paths))) 356 | (if edges 357 | (do-localize host clause edges remaining) 358 | (transform-remote-subgoals (clause-head clause) host nil)))))))) 359 | 360 | (defun one-of-the-vars-p (ls var) 361 | (find-if #L(var-eq-p var !1) ls)) 362 | 363 | (defun is-route-subgoal-alone-p (body sub host) 364 | (with-subgoal sub (:args args) 365 | (let ((def (lookup-subgoal-definition sub))) 366 | (and (is-route-p def) 367 | (= (length (get-subgoals body)) 1) 368 | (var-eq-p host (second args)))))) 369 | 370 | (defun reverse-route-subgoal-alone (sub) 371 | (with-subgoal sub (:name name :args args) 372 | (let ((inverse-name (generate-inverse-name name))) 373 | (setf (subgoal-name sub) inverse-name) 374 | (setf (subgoal-args sub) (swap-first-two-args args))) 375 | (add-route-fact-to-invert name))) 376 | 377 | (defun check-remote-args-in-constructs (clause body host thread) 378 | (do-subgoals body (:args args :subgoal sub :name name) 379 | (let ((first-arg (first args))) 380 | (unless (and (var-p first-arg) 381 | (or (var-eq-p thread first-arg) 382 | (var-eq-p host first-arg))) 383 | (cond 384 | ((is-route-subgoal-alone-p body sub host) 385 | (reverse-route-subgoal-alone sub)) 386 | (t (error 'localize-invalid-error 387 | :text (tostring "Variable is not host: ~a (~a)" first-arg (clause-to-string clause))))))))) 388 | 389 | (defun localize-check-head-by-homes (head homes) 390 | (do-subgoals head (:args args) 391 | (let ((first-arg (first args))) 392 | (cond 393 | ((and (var-p first-arg) (one-of-the-vars-p homes first-arg))) 394 | ((var-p first-arg) (error 'localize-invalid-error 395 | :text (tostring "Variable was not found: ~A (available: ~{~a~^, ~})" (var-name first-arg) (mapcar #'var-name homes)))) 396 | ((addr-p first-arg)) 397 | (t 398 | (error 'localize-invalid-error :text (tostring "invalid destination node: ~A" first-arg))))))) 399 | 400 | (defun localize-check-head (head clause homes host thread) 401 | (localize-check-head-by-homes head homes) 402 | (do-agg-constructs head (:body body :agg-construct c) 403 | (check-remote-args-in-constructs clause body host thread)) 404 | (do-comprehensions head (:left left) 405 | (check-remote-args-in-constructs clause left host thread)) 406 | (do-exists head (:var-list vars :body body) 407 | (localize-check-head-by-homes body (append vars homes))) 408 | (do-conditionals head (:term1 terms1 :term2 terms2) 409 | (localize-check-head terms1 clause homes host thread) 410 | (localize-check-head terms2 clause homes host thread))) 411 | 412 | (defun remove-home-argument-clause (clause) 413 | (multiple-value-bind (host thread) (find-host-nodes clause) 414 | (assert (or host thread)) 415 | (when host 416 | (transform-variable-to-host-id clause host)) 417 | (when thread 418 | (transform-variable-to-thread-id clause thread))) 419 | (transform-drop-subgoal-first-arg clause)) 420 | 421 | (defun remove-home-argument () 422 | (do-rules (:clause clause) 423 | (remove-home-argument-clause clause)) 424 | (do-thread-var-axioms (:clause clause) 425 | (transform-thread-subgoals clause (clause-host-thread clause))) 426 | (do-all-var-axioms (:clause clause) 427 | (remove-home-argument-clause clause)) 428 | (do-node-definitions (:definition def :types typs) 429 | (let ((fst (first typs))) 430 | ;; set definition attribute if first argument is not a regular node. 431 | (unless (type-addr-p fst) 432 | (definition-set-type def fst)) 433 | (setf (definition-types def) (rest typs))))) 434 | 435 | (defmacro with-localize-context ((routes) &body body) 436 | `(let ((,routes (get-route-names)) 437 | (*route-facts-to-invert* nil)) 438 | ,@body)) 439 | 440 | (defun localize () 441 | (with-localize-context (routes) 442 | (do-rules (:clause clause) 443 | (multiple-value-bind (host thread) (find-host-nodes clause) 444 | (localize-start clause routes host thread))) 445 | (create-inverse-routes)) 446 | (remove-home-argument)) 447 | -------------------------------------------------------------------------------- /macros.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (defun build-bind (var body) 4 | (if var `((,var ,body)))) 5 | 6 | ;; Several macro utilities 7 | 8 | (defmacro mac (expr) 9 | `(pprint (macroexpand-1 ',expr))) 10 | 11 | (defmacro tostring (&rest args) 12 | (alexandria:with-gensyms (stream) 13 | `(with-output-to-string (,stream) 14 | (format ,stream ,@args)))) 15 | 16 | (defmacro format-keyword (control &rest arguments) 17 | `(alexandria:format-symbol "KEYWORD" ,control ,@arguments)) 18 | 19 | (defmacro output-symbol (control &rest arguments) 20 | `(intern (string-upcase (tostring ,control ,@arguments)))) 21 | 22 | (defmacro aif (test-form then-form &optional else-form) 23 | `(let ((it ,test-form)) 24 | (if it ,then-form ,else-form))) 25 | 26 | (defmacro awhen (test-form &body body) 27 | `(aif ,test-form 28 | (progn ,@body))) 29 | 30 | (defmacro acond (&rest clauses) 31 | (if (null clauses) 32 | nil 33 | (let ((cl1 (car clauses))) 34 | (if (eq (car cl1) t) 35 | `(progn ,@(cdr cl1)) 36 | (let ((sym (gensym))) 37 | `(let ((,sym ,(car cl1))) 38 | (if ,sym 39 | (let ((it ,sym)) ,@(cdr cl1)) 40 | (acond ,@(cdr clauses))))))))) 41 | 42 | (defmacro ensure-bool (form) `(if ,form t nil)) 43 | 44 | (defmacro on-top-level (&rest forms) 45 | `(eval-when (:compile-toplevel :load-toplevel :execute) 46 | ,@forms)) 47 | 48 | (defmacro with-var (var &body body) 49 | `(let (,var) 50 | ,@body 51 | ,var)) 52 | 53 | (defmacro with-ret (var &body body) 54 | `(with-var ,var 55 | ,@body 56 | ,var)) 57 | 58 | (defmacro letret ((var form) &body body) 59 | `(let ((,var ,form)) 60 | ,@body 61 | ,var)) 62 | 63 | (defmacro always-ret (form &body body) 64 | (alexandria:with-gensyms (ret) 65 | `(letret (,ret ,form) 66 | ,@body))) 67 | 68 | (defmacro iff (test thing) 69 | (alexandria:with-gensyms (ret) 70 | `(let ((,ret ,thing)) 71 | (when (,test ,ret) ,ret)))) 72 | 73 | (defmacro dolist2 ((el1 ls1) (el2 ls2) &body body) 74 | `(loop for ,el1 in ,ls1 75 | for ,el2 in ,ls2 76 | do ,@body)) 77 | 78 | (defmacro with-optional-counter (id &body body) 79 | (if (null id) 80 | body 81 | `(let ((,id 0)) 82 | ,@body 83 | (incf ,id)))) 84 | 85 | (defmacro dolist-filter ((el list filter &optional id) &body body) 86 | `(let (,@(if id `((,id 0)))) 87 | (dolist (,el ,list) 88 | (when (,filter ,el) 89 | ,@(if id `((incf ,id))) 90 | ,@body)))) 91 | 92 | (defmacro dolist-count ((el list &optional id) &body body) 93 | `(let (,@(if id `((,id 0)))) 94 | (dolist (,el ,list) 95 | ,@(if id `((incf ,id))) 96 | ,@body))) 97 | 98 | (defmacro loop-list ((el list &key (id nil) (operation 'do)) &body body) 99 | `(loop for ,el in ,list 100 | ,@(when id `(for ,id upto (length ,list))) 101 | ,operation ,@body)) 102 | 103 | (defmacro with-symbol ((symb expr) &body body) 104 | `(symbol-macrolet ((,symb ,expr)) 105 | ,@body)) 106 | 107 | (defmacro with-car ((cr cons) &body body) 108 | `(with-symbol (,cr (car ,cons)) 109 | ,@body)) 110 | 111 | (defmacro with-cdr ((cr cons) &body body) 112 | `(with-symbol (,cr (cdr ,cons)) 113 | ,@body)) 114 | 115 | (defmacro loop-cons ((el list) &body body) 116 | `(loop for ,el on ,list 117 | do (progn ,@body))) 118 | 119 | (defmacro loop-cons-car ((el-car list) &body body) 120 | (alexandria:with-gensyms (el) 121 | `(loop-cons (,el ,list) 122 | (with-car (,el-car ,el) 123 | ,@body)))) 124 | 125 | (defmacro equal-or (ls &body rest) 126 | `(or ,@(mapcar #'(lambda (el) `(equal ',el ,ls)) rest))) 127 | 128 | (defmacro iterate-hash ((hash key val &key (op 'do)) &body body) 129 | `(loop for ,key being the hash-keys of ,hash 130 | using (hash-value ,val) 131 | ,op ,@body)) 132 | 133 | (defmacro in-directory (new-dir &body body) 134 | "Executes a piece of code inside directory 'new-dir' and goes back to the initial directory." 135 | (alexandria:with-gensyms (old-dir) 136 | `(let ((,old-dir *default-pathname-defaults*)) 137 | (unwind-protect 138 | (progn 139 | (setf *default-pathname-defaults* ,new-dir) 140 | ,@body) 141 | (setf *default-pathname-defaults* ,old-dir))))) 142 | 143 | (defmacro define-with (name list-keywords &key use-self-p) 144 | (alexandria:with-gensyms (thing) 145 | (let ((with-name (output-symbol "with-~a" name)) 146 | (self (if use-self-p `((build-bind ,`,name ,`,thing)) nil)) 147 | (build-binds (loop for kw in list-keywords 148 | collect `(build-bind ,kw `(,',(output-symbol "~a-~a" name kw) ,,thing))))) 149 | `(on-top-level 150 | (defmacro ,with-name (,thing (&key ,@list-keywords ,@(if use-self-p `(,name) nil)) &body code-body) 151 | `(let (,@,@(loop for a in build-binds 152 | collect a) 153 | ,@,@self) 154 | ,@code-body)))))) 155 | 156 | (defmacro define-loop (name with-name list-name list-keywords &key filter-p) 157 | (let* ((key-keys (loop for kw in list-keywords 158 | append 159 | `(,(format-keyword "~a" kw) ,kw))) 160 | (base ``(,',with-name ,el (,,@key-keys) 161 | ,@code-body))) 162 | `(on-top-level 163 | (defmacro ,list-name (ls (&key (id nil) (,name nil) (operation 'do) 164 | ,@(mapcar #'(lambda (kw) `(,kw nil)) list-keywords)) &body code-body) 165 | (alexandria:with-gensyms (el) 166 | `(loop-list (,el ,,(if filter-p ``(filter ,',filter-p ,ls) ``,ls) :id ,id :operation ,operation) 167 | (let (,@(build-bind ,name el)) 168 | ,,base))))))) 169 | 170 | (defmacro define-term-construct (name filter-p list-keywords) 171 | (let* ((do-list-name (output-symbol "do-~a-list" name)) 172 | (with-name (output-symbol "with-~a" name)) 173 | (do-filter-name (output-symbol "do-~as" name)) 174 | (name-keyword (format-keyword "~a" name))) 175 | `(on-top-level 176 | (define-with ,name ,list-keywords) 177 | (define-loop ,name ,with-name ,do-list-name ,list-keywords :filter-p ,filter-p) 178 | (defmacro ,do-filter-name (clause (&key (id nil) (,name nil) (operation 'do) 179 | ,@(mapcar #'(lambda (kw) `(,kw nil)) list-keywords)) &body code-body) 180 | (let ((arg-list `(,',name-keyword ,,name :operation ,operation :id ,id 181 | ,,@(loop for kw in list-keywords 182 | append `(,(format-keyword "~a" kw) ,kw))))) 183 | `(cond 184 | ((clause-p ,clause) 185 | (,',do-list-name (clause-body ,clause) ,arg-list ,@code-body) 186 | (,',do-list-name (clause-head ,clause) ,arg-list ,@code-body)) 187 | (t (,',do-list-name ,clause ,arg-list ,@code-body)))))))) 188 | 189 | ;; Meld related code 190 | 191 | (define-with definition (name types options num-args) :use-self-p t) 192 | (define-loop definition with-definition do-definitions-list (name types options)) 193 | 194 | (defmacro do-definitions ((&key definition name types options id (operation 'do)) &body body) 195 | `(do-definitions-list *definitions* (:name ,name :types ,types :options ,options :definition ,definition 196 | :id ,id :operation ,operation) 197 | ,@body)) 198 | 199 | (defmacro par-collect-definitions ((&key definition name types options) &body body) 200 | (alexandria:with-gensyms (el) 201 | `(par-mapcar #'(lambda (,el) 202 | (with-definition ,el (:name ,name :types ,types :options ,options :definition ,definition) 203 | ,@body)) 204 | *definitions*))) 205 | 206 | (defmacro do-node-definitions ((&key definition name types options id (operation 'do)) 207 | &body body) 208 | `(do-definitions-list *node-definitions* (:name ,name :types ,types :options ,options :definition ,definition 209 | :operation ,operation :id ,id) 210 | ,@body)) 211 | 212 | (define-with extern (name ret-type types)) 213 | (define-loop extern with-extern do-externs (name ret-type types)) 214 | 215 | (define-with clause (head body options) :use-self-p t) 216 | (define-loop clause with-clause do-clauses (head body options)) 217 | 218 | (define-with function (name args ret-type body)) 219 | (define-loop function with-function do-functions (name args ret-type body)) 220 | 221 | (define-with import (imp as from)) 222 | (define-loop import with-import do-imports (imp as from)) 223 | 224 | (defmacro do-rules ((&key head body clause options id (operation 'do)) &body rest) 225 | `(do-clauses *clauses* (:head ,head :body ,body :clause ,clause 226 | :options ,options :id ,id :operation ,operation) 227 | ,@rest)) 228 | 229 | (defmacro do-all-rules ((&key head body clause options) &body rest) 230 | `(progn 231 | (do-rules (:head ,head :body ,body :clause ,clause :options ,options) 232 | ,@rest))) 233 | 234 | (defmacro do-node-var-axioms ((&key head body clause options id (operation 'do)) &body rest) 235 | `(do-clauses *node-var-axioms* (:head ,head :body ,body :clause ,clause 236 | :options ,options :id ,id :operation ,operation) 237 | ,@rest)) 238 | 239 | (defmacro do-thread-var-axioms ((&key head body clause options id (operation 'do)) &body rest) 240 | `(do-clauses *thread-var-axioms* (:head ,head :body ,body :clause ,clause 241 | :options ,options :id ,id :operation ,operation) 242 | ,@rest)) 243 | 244 | (defmacro do-all-var-axioms ((&key head body clause options) &body rest) 245 | `(progn 246 | (do-node-var-axioms (:head ,head :body ,body :clause ,clause :options ,options) 247 | ,@rest) 248 | (do-thread-var-axioms (:head ,head :body ,body :clause ,clause :options ,options) 249 | ,@rest))) 250 | 251 | (defmacro do-node-const-axioms ((&key subgoal) &body rest) 252 | (alexandria:with-gensyms (head) 253 | `(do-clauses *node-const-axioms* (:head ,head) 254 | (do-subgoals ,head (:subgoal ,subgoal) 255 | ,@rest)))) 256 | 257 | (defmacro do-thread-const-axioms ((&key subgoal) &body rest) 258 | (alexandria:with-gensyms (head) 259 | `(do-clauses *thread-const-axioms* (:head ,head) 260 | (do-subgoals ,head (:subgoal ,subgoal) 261 | ,@rest)))) 262 | 263 | (defmacro do-all-const-axioms ((&key subgoal) &body rest) 264 | `(progn 265 | (do-node-const-axioms (:subgoal ,subgoal) 266 | ,@rest) 267 | (do-thread-const-axioms (:subgoal ,subgoal) 268 | ,@rest))) 269 | 270 | (define-term-construct subgoal #'subgoal-p (name args options)) 271 | (define-term-construct comprehension #'comprehension-p (left right variables)) 272 | (define-term-construct exist #'exist-p (var-list body)) 273 | (define-term-construct constraint #'constraint-p (expr)) 274 | (define-term-construct assignment #'assignment-p (var expr)) 275 | (define-term-construct agg-construct #'agg-construct-p (specs vlist body head head0 spec-vars)) 276 | (define-term-construct agg-spec #'agg-spec-p (op var args)) 277 | (define-term-construct constant #'constant-p (name expr type)) 278 | (define-term-construct conditional #'conditional-p (cmp term1 term2)) 279 | (define-term-construct index #'index-p (name field)) 280 | 281 | (define-with process (name instrs) :use-self-p t) 282 | (define-with get-constant (name)) 283 | 284 | (defmacro do-processes ((&key (process nil) (name nil) (instrs nil) (operation 'do)) &body body) 285 | (alexandria:with-gensyms (el) 286 | `(loop-list (,el *processes* :operation ,operation) 287 | (with-process ,el (:name ,name :instrs ,instrs :process ,process) 288 | ,@body)))) 289 | -------------------------------------------------------------------------------- /magic.mgc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flavioc/cl-meld/8bfedb30137a15bfd94c6cfafe0a5107a050dd35/magic.mgc -------------------------------------------------------------------------------- /manip.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (define-condition expr-invalid-error (error) 4 | ((text :initarg :text :reader text))) 5 | 6 | (defmacro define-makes (&rest symbs) 7 | `(on-top-level 8 | ,@(mapcar #'(lambda (sym) 9 | `(defun ,(intern (concatenate 'string "MAKE-" (symbol-name sym))) (a b c) 10 | (declare (ignore b)) 11 | (list ,sym a c))) 12 | symbs))) 13 | 14 | ;; available operations 15 | (define-makes :plus :minus :mul :mod :div 16 | :lesser :lesser-equal :greater :greater-equal 17 | :equal :assign :not-equal :or :and) 18 | 19 | (defmacro define-is-p (&rest symbs) 20 | `(on-top-level 21 | ,@(mapcar #'(lambda (sy) 22 | `(defun ,(intern (concatenate 'string (symbol-name sy) "-P")) (val) 23 | (tagged-p val ,sy))) 24 | symbs))) 25 | 26 | (define-is-p :bool :int :float :var :plus :minus :mul :div :mod 27 | :equal :not-equal 28 | :lesser :lesser-equal :greater :greater-equal 29 | :convert-float :world :cpus :colocated :host 30 | :constraint :extern :aggregate 31 | :true :false :not :head 32 | :tail :cons :call :callf :test-nil :addr 33 | :nil :host-id :thread-id :or :and) 34 | 35 | (defun op-p (val) 36 | (any (plus-p minus-p mul-p div-p mod-p not-equal-p equal-p lesser-p lesser-equal-p greater-p greater-equal-p or-p and-p) val)) 37 | 38 | (defun make-call (name args) `(:call ,name ,args)) 39 | (defun call-name (call) (second call)) 40 | (defun call-args (call) (third call)) 41 | 42 | (defun set-call-args (call new-args) (setf (third call) new-args)) 43 | (defsetf call-args set-call-args) 44 | 45 | (defun make-callf (name args) `(:callf ,name ,args)) 46 | (defun callf-name (call) (second call)) 47 | (defun callf-args (call) (third call)) 48 | 49 | (defun set-callf-args (call new-args) (setf (third call) new-args)) 50 | (defsetf callf-args set-callf-args) 51 | 52 | (defun lookup-function (name) 53 | (let ((fun (find-if #'(lambda (x) (string-equal (callf-name x) name)) *functions*))) 54 | fun)) 55 | 56 | (defun make-function (name args ret-type body) 57 | `(:function ,name ,args ,ret-type ,body)) 58 | (defun function-name (fun) (second fun)) 59 | (defun function-args (fun) (third fun)) 60 | (defun function-ret-type (fun) (fourth fun)) 61 | (defun function-body (fun) (fifth fun)) 62 | 63 | (defun make-cons (h ts) `(:cons ,h ,ts)) 64 | (defun cons-head (c) (second c)) 65 | (defun cons-tail (c) (third c)) 66 | 67 | (defun set-cons-head (cons head) 68 | (setf (second cons) head)) 69 | (defsetf cons-head set-cons-head) 70 | 71 | (defun set-cons-tail (cons tail) 72 | (setf (third cons) tail)) 73 | (defsetf cons-tail set-cons-tail) 74 | 75 | (defun make-head (c &optional type) `(:head ,c ,type)) 76 | (defun head-list (c) (second c)) 77 | 78 | (defun set-head-list (head list) 79 | (setf (second head) list)) 80 | (defsetf head-list set-head-list) 81 | 82 | (defun make-tail (c) `(:tail ,c)) 83 | (defun tail-list (c) (second c)) 84 | 85 | (defun set-tail-list (tail list) 86 | (setf (second tail) list)) 87 | (defsetf tail-list set-tail-list) 88 | 89 | (defun make-true () '(:true)) 90 | (defun make-false () '(:false)) 91 | 92 | (defun make-not (expr &optional type) `(:not ,expr ,type)) 93 | (defun not-expr (not) (second not)) 94 | 95 | (defun set-not-expr (not expr) 96 | (setf (second not) expr)) 97 | (defsetf not-expr set-not-expr) 98 | 99 | (defun make-test-nil (expr) `(:test-nil ,expr)) 100 | (defun test-nil-expr (tn) (second tn)) 101 | 102 | (defun set-test-nil-expr (test expr) 103 | (setf (second test) expr)) 104 | (defsetf test-nil-expr set-test-nil-expr) 105 | 106 | (defun make-nil () (list :nil)) 107 | 108 | (defun make-addr (num) (list :addr num :type-addr)) 109 | (defun addr-num (addr) (second addr)) 110 | (defun set-addr-num (addr new-num) 111 | (setf (second addr) new-num)) 112 | (defsetf addr-num set-addr-num) 113 | 114 | (defun option-has-tag-p (opts opt) (some #L(tagged-p !1 opt) opts)) 115 | 116 | ;; to take the home node from the first subgoal or agg-construct 117 | (defun find-host-nodes (clause) 118 | "Returns first node and thread (if any) from a clause." 119 | (let (first-thread first-node) 120 | (with-clause clause (:body body :head head) 121 | (do-subgoals (if (get-subgoals body) body head) (:name name :args args) 122 | (let ((def (lookup-definition name))) 123 | (with-definition def (:types types) 124 | (let ((fst (first types))) 125 | (if (or (type-node-p fst) (type-addr-p fst)) 126 | (unless first-node 127 | (setf first-node (first args))) 128 | (unless first-thread 129 | (when (type-thread-p fst) 130 | (setf first-thread (first args))))))))) 131 | (unless first-node 132 | (dolist (a (get-assignments (clause-body clause))) 133 | (with-assignment a (:expr e :var var) 134 | (when (and (host-p e) (not first-node)) 135 | (setf first-node var))))) 136 | (unless first-thread 137 | (dolist (a (get-assignments (clause-body clause))) 138 | (with-assignment a (:expr e :var var) 139 | (when (and (thread-id-p e) (not first-thread)) 140 | (setf first-thread var)))))) 141 | (values first-node first-thread))) 142 | 143 | (defun find-host-nodes-head-only (head) 144 | "Returns first node and thread (if any) from a clause." 145 | (let (first-node first-thread) 146 | (do-subgoals head (:name name :args args) 147 | (let ((def (lookup-definition name))) 148 | (with-definition def (:types types) 149 | (let ((fst (first types))) 150 | (if (or (type-addr-p fst) (type-node-p fst)) 151 | (unless first-node 152 | (setf first-node (first args)))) 153 | (unless first-thread 154 | (when (type-thread-p fst) 155 | (setf first-thread (first args)))))))) 156 | (values first-node first-thread))) 157 | 158 | (defun clause-host-thread (clause) 159 | (multiple-value-bind (host thread) (find-host-nodes clause) 160 | (declare (ignore host)) 161 | thread)) 162 | 163 | (defun make-definition (name typs options) `(:definition ,name ,typs ,options)) 164 | (defun definition-p (def) (tagged-p def :definition)) 165 | (defun definition-name (def) (second def)) 166 | (defun definition-types (def) (third def)) 167 | (defun set-definition-types (def new-types) 168 | (setf (third def) new-types)) 169 | (defsetf definition-types set-definition-types) 170 | (defun definition-num-args (def) 171 | (length (definition-types def))) 172 | (defun definition-options (def) (fourth def)) 173 | (defun definition-add-option (def opt) (push opt (fourth def))) 174 | (defun definition-has-option-p (def opt) 175 | (has-elem-p (definition-options def) opt)) 176 | (defun definition-has-tagged-option-p (def opt) 177 | (some #L(tagged-p !1 opt) (definition-options def))) 178 | (defun definition-get-tagged-option (def opt) 179 | (let ((res (find-if #L(tagged-p !1 opt) (definition-options def)))) 180 | (when res 181 | (second res)))) 182 | (defun definition-add-tagged-option (def name &rest rest) 183 | (definition-add-option def `(,name ,@rest))) 184 | (defun definition-set-cyclical (def) (definition-add-option def :cycle)) 185 | (defun definition-is-cyclical-p (def) (definition-has-option-p def :cycle)) 186 | (defun definition-is-compact-p (def) (definition-has-option-p def :compact)) 187 | (defun definition-set-thread (def) (definition-add-option def :thread)) 188 | (defun definition-is-thread-p (def) (definition-has-option-p def :thread)) 189 | (defun definition-set-update (def updates count) 190 | (definition-add-tagged-option def :update (list updates count))) 191 | (defun definition-is-update-p (def) 192 | (definition-get-tagged-option def :update)) 193 | (defun definition-set-type (def typ) 194 | (definition-add-tagged-option def :type typ)) 195 | (defun definition-get-type (def) 196 | (definition-get-tagged-option def :type)) 197 | (defun definition-get-update-count (def) 198 | (second (definition-get-tagged-option def :update))) 199 | (defun definition-get-update-definition (def) 200 | (first (definition-get-tagged-option def :update))) 201 | 202 | (defun definition-set-local-agg (def) 203 | (definition-add-option def :local-agg)) 204 | (defun definition-has-local-agg-p (def) 205 | (definition-has-option-p def :local-agg)) 206 | (defun definition-set-strata (def level) 207 | (definition-add-tagged-option def :strat level)) 208 | (defun definition-get-strata (def) 209 | (definition-get-tagged-option def :strat)) 210 | (defun definition-set-linear-id (def id) 211 | (definition-add-tagged-option def :id2 id)) 212 | (defun definition-set-persistent-id (def id) 213 | (definition-add-tagged-option def :id2 id)) 214 | (defun definition-get-linear-id (def) 215 | (definition-get-tagged-option def :id2)) 216 | (defun definition-get-persistent-id (def) 217 | (definition-get-tagged-option def :id2)) 218 | 219 | (defun is-init-p (def) 220 | (definition-has-option-p def :init-tuple)) 221 | (defun is-route-p (def) 222 | (definition-has-option-p def :route)) 223 | (defun is-linear-p (def) 224 | (definition-has-option-p def :linear)) 225 | (defun is-persistent-p (def) 226 | (not (is-linear-p def))) 227 | (defun is-action-p (def) 228 | (definition-has-option-p def :action)) 229 | (defun is-reverse-route-p (def) 230 | (definition-has-tagged-option-p def :reverse-route)) 231 | (defun is-reused-p (def) 232 | (definition-has-option-p def :reused)) 233 | (defun definition-set-reused (def) 234 | (definition-add-option def :reused)) 235 | (defun definition-is-instruction-p (def) 236 | (definition-has-option-p def :instruction)) 237 | (defun definition-is-special-p (def) 238 | (definition-has-option-p def :special)) 239 | 240 | (defun find-init-predicate (defs) (find-if #'is-init-p defs)) 241 | (defun find-init-predicate-name (defs) 242 | (definition-name (find-init-predicate defs))) 243 | (defun get-routes (&optional (code *ast*)) 244 | (filter #'is-route-p (definitions code))) 245 | 246 | (defun get-route-names (&optional (code *ast*)) 247 | (mapcar #'definition-name (get-routes code))) 248 | 249 | (defun subgoal-matches-def-p (sub def) 250 | (equal (subgoal-name sub) (definition-name def))) 251 | (defun subgoal-match-p (sub1 sub2) 252 | (equal (subgoal-name sub1) (subgoal-name sub2))) 253 | 254 | (defun make-aggregate (agg typ &optional mod) `(:aggregate ,agg ,typ ,mod)) 255 | (defun aggregate-agg (agg) (second agg)) 256 | (defun aggregate-type (agg) (third agg)) 257 | 258 | (defun aggregate-mod (agg) (fourth agg)) 259 | (defun aggregate-mod-is-input-p (aggmod) (tagged-p aggmod :input)) 260 | (defun aggregate-mod-is-output-p (aggmod) (tagged-p aggmod :output)) 261 | (defun aggregate-mod-is-immediate-p (aggmod) (eq aggmod :immediate)) 262 | (defun aggregate-mod-io-name (aggmod) (second aggmod)) 263 | (defun aggregate-mod-includes-home-p (aggmod) 264 | (and (> (length aggmod) 2) 265 | (eq (third aggmod) :home))) 266 | (defun aggregate-mod-include-home (aggmod) 267 | (assert (= (length aggmod) 2)) 268 | (push-end :home aggmod)) 269 | 270 | (defun definition-aggregate (def) 271 | (with-definition def (:types typs) (find-if #'aggregate-p typs))) 272 | 273 | (defun arg-type (arg) 274 | (if (aggregate-p arg) 275 | (aggregate-type arg) 276 | arg)) 277 | (defun definition-arg-types (typs) (mapcar #'arg-type typs)) 278 | 279 | (defun definition-aggregate-p (def) 280 | (with-definition def (:types typs) 281 | (some #'aggregate-p typs))) 282 | 283 | (defun make-extern (name ret-type types &optional id poly-p) `(:extern ,name ,ret-type ,types ,id ,poly-p)) 284 | (defun extern-name (ext) (second ext)) 285 | (defun extern-ret-type (ext) (third ext)) 286 | (defun extern-types (ext) (fourth ext)) 287 | (defun extern-id (ext) (fifth ext)) 288 | (defun extern-poly-p (ext) (sixth ext)) 289 | 290 | (defun make-constraint (expr &optional (priority 0)) (list :constraint expr priority)) 291 | (defun constraint-expr (ls) (second ls)) 292 | (defun constraint-priority (ls) (third ls)) 293 | 294 | (defun set-constraint-expr (constraint new-expr) 295 | (setf (second constraint) new-expr)) 296 | (defsetf constraint-expr set-constraint-expr) 297 | 298 | (defun complex-const-p (s) 299 | (or (and (struct-p s) 300 | (every #'literal-p (struct-list s))) 301 | (when (cons-p s) 302 | (loop while (cons-p s) 303 | while (literal-p (cons-head s)) 304 | do (setf s (cons-tail s))) 305 | (nil-p s)))) 306 | 307 | (defun literal-p (s) 308 | (or (int-p s) (float-p s) 309 | (string-constant-p s) 310 | (addr-p s))) 311 | 312 | (defun const-p (s) 313 | (or (literal-p s) 314 | (get-constant-p s))) 315 | 316 | (defun make-op (op op1 op2) 317 | `(,op ,op1 ,op2)) 318 | (defun op-op (val) (tagged-tag val)) 319 | (defun op-op1 (val) (second val)) 320 | (defun op-op2 (val) (third val)) 321 | 322 | (defun set-op-op1 (o expr) 323 | (setf (second o) expr)) 324 | (defsetf op-op1 set-op-op1) 325 | 326 | (defun set-op-op2 (o expr) 327 | (setf (third o) expr)) 328 | (defsetf op-op2 set-op-op2) 329 | 330 | (defun make-let (var expr body &optional type) `(:let ,var ,expr ,body ,type)) 331 | (defun let-p (l) (tagged-p l :let)) 332 | (defun let-var (l) (second l)) 333 | (defun let-expr (l) (third l)) 334 | (defun let-body (l) (fourth l)) 335 | (defun set-let-var (l v) 336 | (setf (second l) v)) 337 | (defsetf let-var set-let-var) 338 | (defun set-let-expr (l expr) 339 | (setf (third l) expr)) 340 | (defsetf let-expr set-let-expr) 341 | (defun set-let-body (l body) 342 | (setf (fourth l) body)) 343 | (defsetf let-body set-let-body) 344 | 345 | (defun make-argument (id) 346 | (assert (numberp id)) 347 | (assert (and (>= id 1) (<= id 9))) 348 | `(:argument ,id :type-string)) 349 | (defun argument-p (x) (tagged-p x :argument)) 350 | (defun argument-id (x) (second x)) 351 | 352 | (defun make-get-constant (name &optional (type :all)) `(:get-constant ,name ,type)) 353 | (defun get-constant-p (c) (tagged-p c :get-constant)) 354 | (defun get-constant-name (c) (second c)) 355 | 356 | (defun make-if (cmp e1 e2 &optional type) `(:if ,cmp ,e1 ,e2 ,type)) 357 | (defun if-p (i) (tagged-p i :if)) 358 | (defun if-cmp (i) (second i)) 359 | (defun if-e1 (i) (third i)) 360 | (defun if-e2 (i) (fourth i)) 361 | (defun set-if-cmp (i cmp) 362 | (setf (second i) cmp)) 363 | (defsetf if-cmp set-if-cmp) 364 | (defun set-if-e1 (i e1) 365 | (setf (third i) e1)) 366 | (defsetf if-e1 set-if-e1) 367 | (defun set-if-e2 (i e2) 368 | (setf (fourth i) e2)) 369 | (defsetf if-e2 set-if-e2) 370 | 371 | (defun make-conditional (cmp t1 t2) `(:conditional ,cmp ,t1 ,t2)) 372 | (defun conditional-p (x) (tagged-p x :conditional)) 373 | (defun conditional-cmp (x) (second x)) 374 | (defun conditional-term1 (x) (third x)) 375 | (defun conditional-term2 (x) (fourth x)) 376 | (defun set-conditional-cmp (x cmp) 377 | (setf (second x) cmp)) 378 | (defsetf conditional-cmp set-conditional-cmp) 379 | (defun set-conditional-term1 (x t1) 380 | (setf (third x) t1)) 381 | (defsetf conditional-term1 set-conditional-term1) 382 | (defun set-conditional-term2 (x t2) 383 | (setf (fourth x) t2)) 384 | (defsetf conditional-term2 set-conditional-term2) 385 | 386 | (defun make-string-constant (v) `(:string ,v :type-string)) 387 | (defun string-constant-val (x) (second x)) 388 | (defun string-constant-p (x) (tagged-p x :string)) 389 | 390 | (defun make-bool (v) `(:bool ,v :type-bool)) 391 | (defun bool-val (b) (second b)) 392 | 393 | (defun int-val (val) (second val)) 394 | (defun make-int (int &optional typ) 395 | (if typ 396 | `(:int ,int ,typ) 397 | `(:int ,int))) 398 | (defun make-forced-int (int) (make-int int :type-int)) 399 | 400 | (defun float-val (val) (second val)) 401 | (defun make-float (flt) `(:float ,flt :type-float)) 402 | 403 | (defun int-float-val (x) (second x)) 404 | 405 | (defun transform-int-to-float (expr) 406 | (setf (first expr) :float)) 407 | 408 | (defun make-host-id () '(:host-id :type-addr)) 409 | (defun make-thread-id () '(:thread-id :type-thread)) 410 | 411 | (defun make-convert-float (expr) `(:convert-float ,expr :type-float)) 412 | (defun convert-float-expr (flt) (second flt)) 413 | 414 | (defun set-convert-float-expr (c expr) 415 | (setf (second c) expr)) 416 | (defsetf convert-float-expr set-convert-float-expr) 417 | 418 | (defun make-struct (ls) `(:struct ,ls)) 419 | (defun struct-p (x) (tagged-p x :struct)) 420 | (defun struct-list (x) (second x)) 421 | (defun set-struct-list (s ls) 422 | (setf (second s) ls)) 423 | (defsetf struct-list set-struct-list) 424 | 425 | (defun make-struct-val (idx var &optional typ) (assert (var-p var)) `(:struct-val ,idx ,var ,typ)) 426 | (defun struct-val-p (x) (tagged-p x :struct-val)) 427 | (defun struct-val-idx (x) (second x)) 428 | (defun struct-val-var (x) (third x)) 429 | (defun set-struct-val-var (x v) 430 | (setf (third x) v)) 431 | (defsetf struct-val-var set-struct-val-var) 432 | 433 | (defun make-world () (list :world)) 434 | (defun make-cpus () (list :cpus)) 435 | (defun make-host () (list :host)) 436 | 437 | (defun make-var (var &optional typ) `(:var ,(if (stringp var) (str->sym var) var) ,@(if typ `(,typ) nil))) 438 | (defun var-name (val) (second val)) 439 | (defun var-type (val) (third val)) 440 | (defun var-eq-p (v1 v2) (equal (var-name v1) (var-name v2))) 441 | (defun set-var-type (var ty) 442 | (cond 443 | ((= (length var) 2) 444 | (push-end ty var)) 445 | (t 446 | (setf (third var) ty)))) 447 | (defsetf var-type set-var-type) 448 | 449 | (defparameter *var-counter* 0) 450 | (defun generate-random-var-name () 451 | (tostring "MV~a" (incf *var-counter*))) 452 | (defun generate-random-var (&optional typ) 453 | "Generates a new variable name." 454 | (make-var (generate-random-var-name) typ)) 455 | 456 | ;;;; ASSIGNMENTS 457 | 458 | (defun make-assignment (var expr) `(:assign ,var ,expr)) 459 | (defun assignment-p (ls) (tagged-p ls :assign)) 460 | (defun assignment-var (ls) (second ls)) 461 | (defun assignment-expr (ls) (third ls)) 462 | 463 | (defun set-assignment-var (ass new-var) 464 | (setf (second ass) new-var)) 465 | (defsetf assignment-var set-assignment-var) 466 | 467 | (defun set-assignment-expr (ass new-expr) 468 | (setf (third ass) new-expr)) 469 | (defsetf assignment-expr set-assignment-expr) 470 | 471 | ;;;; COMPREHENSIONS 472 | 473 | (defun make-comprehension (left right variables) 474 | (list :comprehension left right variables)) 475 | 476 | (defun comprehension-p (comp) (tagged-p comp :comprehension)) 477 | (defun comprehension-left (comp) (second comp)) 478 | (defun comprehension-right (comp) (third comp)) 479 | (defun comprehension-variables (comp) (fourth comp)) 480 | (defun set-comprehension-left (comp left) 481 | (setf (second comp) left)) 482 | (defsetf comprehension-left set-comprehension-left) 483 | (defun set-comprehension-right (comp right) 484 | (setf (third comp) right)) 485 | (defsetf comprehension-right set-comprehension-right) 486 | 487 | ;;;; AGGREGATES 488 | 489 | (defun make-agg-spec (op var &optional args) `(:agg-spec ,op ,var ,args)) 490 | (defun agg-spec-p (x) (tagged-p x :agg-spec)) 491 | (defun agg-spec-op (x) (second x)) 492 | (defun agg-spec-var (x) (third x)) 493 | (defun agg-spec-args (x) (fourth x)) 494 | 495 | (defun make-agg-construct (spec vlist body &optional head head0) 496 | `(:agg-construct ,spec ,vlist ,body ,head ,head0)) 497 | (defun agg-construct-p (x) (tagged-p x :agg-construct)) 498 | (defun agg-construct-specs (a) (second a)) 499 | (defun agg-construct-vlist (a) (third a)) 500 | (defun agg-construct-body (a) (fourth a)) 501 | (defun agg-construct-head (a) (fifth a)) 502 | (defun agg-construct-head0 (a) (sixth a)) 503 | (defun agg-construct-spec-vars (a) (mapcar #'agg-spec-var (agg-construct-specs a))) 504 | 505 | (defun set-agg-construct-vlist (c new) 506 | (setf (third c) new)) 507 | (defsetf agg-construct-vlist set-agg-construct-vlist) 508 | (defun set-agg-construct-body (c body) 509 | (setf (fourth c) body)) 510 | (defsetf agg-construct-body set-agg-construct-body) 511 | (defun set-agg-construct-head0 (c body) 512 | (setf (sixth c) body)) 513 | (defsetf agg-construct-head0 set-agg-construct-head0) 514 | 515 | ;;;; EXISTS 516 | 517 | (defun make-exist (vars body) 518 | `(:exists ,vars ,body)) 519 | (defun exist-p (ex) (tagged-p ex :exists)) 520 | (defun exist-var-list (ex) (second ex)) 521 | (defun exist-body (ex) (third ex)) 522 | 523 | (defun set-exist-body (ex new-body) 524 | (setf (third ex) new-body)) 525 | (defsetf exist-body set-exist-body) 526 | 527 | ;;;; SUBGOALS 528 | 529 | (defun make-subgoal (name args &optional options) 530 | (list :subgoal name args options)) 531 | 532 | (defun subgoal-p (ls) (tagged-p ls :subgoal)) 533 | (defun subgoal-name (subgoal) (second subgoal)) 534 | (defun set-subgoal-name (subgoal name) 535 | (setf (second subgoal) name)) 536 | (defsetf subgoal-name set-subgoal-name) 537 | (defun subgoal-args (subgoal) (third subgoal)) 538 | (defun set-subgoal-args (subgoal new-args) 539 | (setf (third subgoal) new-args)) 540 | (defsetf subgoal-args set-subgoal-args) 541 | (defun subgoal-options (subgoal) (fourth subgoal)) 542 | (defun subgoal-has-option-p (subgoal opt) 543 | (has-elem-p (subgoal-options subgoal) opt)) 544 | (defun subgoal-add-option (subgoal opt) 545 | (setf (fourth subgoal) (cons opt (fourth subgoal)))) 546 | (defun subgoal-add-tagged-option (subgoal opt arg) 547 | (subgoal-add-option subgoal `(,opt ,arg))) 548 | (defun subgoal-add-route (sub route) 549 | (subgoal-add-tagged-option sub :route route)) 550 | (defun subgoal-get-remote-dest (subgoal) 551 | (first (subgoal-get-tagged-option subgoal :route))) 552 | 553 | (defun subgoal-set-thread (sub) 554 | (subgoal-add-option sub :thread)) 555 | (defun subgoal-is-thread-p (sub) 556 | (subgoal-has-option-p sub :thread)) 557 | 558 | (defun subgoal-get-tagged-option (subgoal opt) 559 | (let ((res (find-if #L(tagged-p !1 opt) (subgoal-options subgoal)))) 560 | (when res 561 | (rest res)))) 562 | (defun subgoal-has-tagged-option-p (subgoal opt) 563 | (ensure-bool (subgoal-get-tagged-option subgoal opt))) 564 | (defun subgoal-has-min-p (subgoal) 565 | (subgoal-has-tagged-option-p subgoal :min)) 566 | (defun subgoal-add-min (subgoal var) 567 | (subgoal-add-tagged-option subgoal :min var)) 568 | (defun subgoal-has-random-p (subgoal) 569 | (subgoal-has-option-p subgoal :random)) 570 | (defun subgoal-get-min-variable (subgoal) 571 | (let ((ret (subgoal-get-tagged-option subgoal :min))) 572 | (when ret 573 | (first ret)))) 574 | (defun subgoal-get-min-variable-position (subgoal) 575 | (let ((var (subgoal-get-min-variable subgoal))) 576 | (when var 577 | (with-subgoal subgoal (:args args) 578 | (let ((pos 0)) 579 | (dolist (arg args) 580 | (when (var-eq-p arg var) 581 | (return-from subgoal-get-min-variable-position pos)) 582 | (incf pos))))))) 583 | (defun subgoal-is-remote-p (subgoal) 584 | (subgoal-get-remote-dest subgoal)) 585 | (defun subgoal-is-const-p (subgoal) 586 | (with-subgoal subgoal (:args args) 587 | ; we want to ignore constants in this case (faster loading) 588 | (every #L(and (or (complex-const-p !1) (const-p !1)) (not (get-constant-p !1))) args))) 589 | (defun subgoal-add-delay (subgoal delay) 590 | (assert (and (numberp delay) (> delay 0))) 591 | (subgoal-add-tagged-option subgoal :delay delay)) 592 | (defun subgoal-has-delay-p (subgoal) 593 | (subgoal-get-tagged-option subgoal :delay)) 594 | (defun subgoal-delay-value (subgoal) 595 | (first (subgoal-get-tagged-option subgoal :delay))) 596 | (defun subgoal-set-reused (sub) 597 | (subgoal-add-option sub :reused)) 598 | (defun subgoal-is-reused-p (sub) 599 | (subgoal-has-option-p sub :reused)) 600 | (defun subgoal-will-reuse-other-p (sub) 601 | (subgoal-has-tagged-option-p sub :will-reuse)) 602 | (defun subgoal-will-reuse-other (sub sub2) 603 | (subgoal-add-tagged-option sub :will-reuse sub2)) 604 | (defun subgoal-get-reused (sub) 605 | (let ((opt (subgoal-get-tagged-option sub :will-reuse))) 606 | (when opt 607 | (first opt)))) 608 | (defun subgoal-will-modify (sub sub2) 609 | (subgoal-add-tagged-option sub :will-modify sub2)) 610 | (defun subgoal-will-modify-p (sub) 611 | (subgoal-has-tagged-option-p sub :will-modify)) 612 | 613 | (defun lookup-definition-types (pred) 614 | (alexandria:when-let ((def (lookup-definition pred))) 615 | (definition-types def))) 616 | 617 | (defun lookup-definition (pred &optional (defs *definitions*)) 618 | (find-if #L(string-equal pred (definition-name !1)) defs)) 619 | 620 | (defun lookup-subgoal-definition (subgoal &optional (defs *definitions*)) 621 | (lookup-definition (subgoal-name subgoal) defs)) 622 | 623 | (defun lookup-def-id (def-name) 624 | (do-definitions (:id id :name name) 625 | (if (string-equal name def-name) (return-from lookup-def-id id)))) 626 | 627 | (defun lookup-extern (name) 628 | (find-if #L(string-equal name (extern-name !1)) *externs*)) 629 | 630 | (defun make-const-definition (name expr) `(:const ,name ,expr)) 631 | (defun const-definition-p (const) (tagged-p const :const)) 632 | (defun const-definition-name (const) (second const)) 633 | (defun const-definition-expr (const) (third const)) 634 | 635 | (defun has-constraints-p (subgoals) (some #'constraint-p subgoals)) 636 | (defun has-assignments-p (subgoals) (some #'assignment-p subgoals)) 637 | 638 | (defun op-to-string (op) 639 | (case op 640 | (:or "||") 641 | (:and "&&") 642 | (:plus "+") 643 | (:minus "-") 644 | (:mul "*") 645 | (:div "/") 646 | (:mod "%") 647 | (:equal "=") 648 | (:not-equal "!=") 649 | (:lesser "<") 650 | (:lesser-equal "<=") 651 | (:greater ">") 652 | (:greater-equal ">="))) 653 | 654 | (defmacro eq-or (sym &rest symbols) 655 | `(or ,@(mapcar #'(lambda (s) `(eq ,sym ,s)) symbols))) 656 | 657 | (defun eq-arith-p (sym) (eq-or sym :plus :minus :mul :div :mod)) 658 | (defun eq-num-cmp-p (sym) (eq-or sym :lesser :lesser-equal :greater :greater-equal)) 659 | (defun eq-cmp-p (sym) (eq-or sym :equal :not-equal :lesser :lesser-equal :greater :greater-equal :or :and)) 660 | 661 | ;; imports 662 | (defun make-import (imp as file) `(:import ,imp ,as ,file)) 663 | (defun import-p (x) (tagged-p x :import)) 664 | (defun import-imp (x) (second x)) 665 | (defun import-as (x) (third x)) 666 | (defun import-from (x) (fourth x)) 667 | -------------------------------------------------------------------------------- /meld.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (defun localize-code (file) 4 | (setf *name-counter* 0) ;; reset counter for auto-generated fact names 5 | (setf *var-counter* 0) 6 | (printdbg "Parsing file ~a" file) 7 | (let ((ast (parse-meld-file file))) 8 | (set-abstract-syntax-tree ast) 9 | (printdbg "Checking topology...") 10 | (optimize-topology) 11 | (printdbg "Typechecking...") 12 | (type-check) 13 | (ast-remove-unneeded-definitions ast) 14 | (agg-transformer) 15 | (printdbg "Localizing rules...") 16 | (localize) 17 | (stratify)) 18 | *ast*) 19 | 20 | (defun do-meld-compile (file out &optional (is-data-p nil)) 21 | (with-node-type-context 22 | (localize-code file) 23 | (printdbg "Compiling AST into VM instructions...") 24 | (let ((compiled (compile-ast)) 25 | (compiled-rules (compile-ast-rules))) 26 | (setf *code* compiled) 27 | (setf *code-rules* compiled-rules) 28 | (printdbg "All compiled. Now optimizing result...") 29 | (optimize-code) 30 | (printdbg "Optimized. Writing byte-code to ~a.m" out) 31 | (if is-data-p 32 | (output-data-file out) 33 | (output-code out)) 34 | (printdbg "Writing C++ code to ~a.cpp" out) 35 | (output-c-code out) 36 | (printdbg "All done.")) 37 | t)) 38 | 39 | (defun meld-compile (file out &optional (is-data-p nil)) 40 | (format t "==> Compiling file ~a~% to ~a.m~%" file out) 41 | (handler-case 42 | (progn 43 | (do-meld-compile file out is-data-p) 44 | t) 45 | (file-not-found-error (c) (format t "File not found: ~a~%" (text c)) nil) 46 | (parse-failure-error (c) (format t "Parse error at line ~a: ~a~%" (line c) (text c)) nil) 47 | (expr-invalid-error (c) (format t "Expression error: ~a~%" (text c)) nil) 48 | (type-invalid-error (c) (format t "Type error: ~a~%" (text c)) nil) 49 | (localize-invalid-error (c) (format t "Localization error: ~a~%" (text c)) nil) 50 | (stratification-error (c) (format t "Stratification error: ~a~%" (text c)) nil) 51 | (compile-invalid-error (c) (format t "Compile error: ~a~%" (text c)) nil) 52 | (external-invalid-error (c) (format t "External functions: ~a~%" (text c)) nil) 53 | (output-invalid-error (c) (format t "Output error: ~a~%" (text c)) nil))) 54 | 55 | (defun meld-compile-exit (file out &optional (is-data-p nil)) 56 | (sb-ext:quit :unix-status (if (meld-compile file out is-data-p) 0 1))) 57 | 58 | (defun meld-clear-variables () 59 | (setf *ast* nil) 60 | (setf *code* nil) 61 | (setf *code-rules* nil)) 62 | 63 | (defun meld-compile-list (pairs) 64 | (loop for (in out) in pairs 65 | do (unless (meld-compile in out) 66 | (format t "PROBLEM COMPILING ~a~%" in) 67 | (meld-clear-variables) 68 | (sb-ext:gc :full t) 69 | (return-from meld-compile-list nil))) 70 | t) 71 | 72 | ;; this is to be removed... soon 73 | 74 | (defun create-debug-file (prog ext) 75 | (concatenate 'string "/Users/flaviocruz/Projects/meld/" prog ext)) 76 | 77 | (defun comp (prog &optional (out nil)) 78 | (let ((output-file (if out out (pathname-name (pathname prog))))) 79 | (meld-compile (create-debug-file prog ".meld") 80 | (create-debug-file output-file "")))) 81 | 82 | (defun comp-data (prog &optional (out nil)) 83 | (let ((output-file (if out out (pathname-name (pathname prog))))) 84 | (meld-compile (create-debug-file prog ".meld") 85 | (create-debug-file output-file "") t))) 86 | -------------------------------------------------------------------------------- /models/base.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (defparameter *major-version* 0) 4 | (defparameter *minor-version* 14) 5 | 6 | (defparameter *init-tuple* (make-definition "_init" '(:type-addr) '(:init-tuple :linear))) 7 | 8 | (defparameter *base-tuples* nil) 9 | 10 | (defun base-tuple-defined-p (name) 11 | (find-if #'(lambda (d) (string-equal (definition-name d) name)) *base-tuples*)) 12 | 13 | (defmacro deftuple (name types &rest options) 14 | (let ((real-name (if (symbolp name) (string-downcase (symbol-name name)) name))) 15 | `(unless (base-tuple-defined-p ,real-name) 16 | (push-end (make-definition ,real-name ',types ',options) *base-tuples*)))) 17 | 18 | (defun ast-add-base-tuples (ast use-threads-p seen-subgoals) 19 | (let ((copy (mapcar #'copy-tree (filter #L(with-definition !1 (:name name) 20 | (member name seen-subgoals :test #'string-equal)) 21 | *base-tuples*)))) 22 | ;; default predicates are added if only they are used. 23 | (when use-threads-p 24 | (push (make-definition "_init_thread" '(:type-thread) '(:init-tuple :linear :thread)) copy)) 25 | (push (copy-tree *init-tuple*) copy) 26 | (setf (definitions ast) (append copy (definitions ast))))) 27 | -------------------------------------------------------------------------------- /models/parallel.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (deftuple setcolor (:type-addr :type-int :type-int :type-int) :action :linear) 4 | (deftuple setedgelabel (:type-addr :type-addr :type-string) :action :linear) 5 | (deftuple write-string (:type-addr :type-string) :action :linear) 6 | (deftuple setColor2 (:type-addr :type-int) :action) 7 | (deftuple stop-program (:type-addr) :action :linear :instruction) 8 | (deftuple set-priority (:type-addr :type-float) :action :linear :instruction) 9 | (deftuple add-priority (:type-addr :type-float) :action :linear :instruction) 10 | (deftuple schedule-next (:type-addr) :action :linear :instruction) 11 | (deftuple set-default-priority (:type-addr :type-float) :action :linear :instruction) 12 | (deftuple set-moving (:type-addr) :action :linear :instruction) 13 | (deftuple set-static (:type-addr) :action :linear :instruction) 14 | (deftuple set-affinity (:type-addr :type-addr) :action :linear :instruction) 15 | (deftuple set-cpu (:type-addr :type-thread) :action :linear :instruction) 16 | (deftuple remove-priority (:type-addr) :action :linear :instruction) 17 | (deftuple just-moved (:type-addr) :linear :special) 18 | (deftuple thread-list (:type-thread (:type-list :type-thread)) :special :thread :compact) 19 | (deftuple other-thread (:type-thread :type-thread :type-int) :special :thread :compact) 20 | (deftuple leader-thread (:type-thread :type-thread) :special :thread :compact) 21 | -------------------------------------------------------------------------------- /optimize.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :cl-meld) 3 | 4 | (defun matches-mv-host-to-reg-p (instr) 5 | (eq (first instr) :move-host-id-to-reg)) 6 | 7 | (defun matches-op-addr-equal-p (instr) 8 | (and (eq (first instr) :addr-equal) 9 | (reg-p (vm-op-dest instr)) 10 | (reg-eq-p (vm-op-dest instr) (make-reg 2)) 11 | (reg-p (vm-op-v1 instr)) 12 | (reg-p (vm-op-v2 instr)) 13 | (reg-eq-p (vm-op-v1 instr) (make-reg 0)) 14 | (reg-eq-p (vm-op-v2 instr) (make-reg 1)))) 15 | 16 | (defun matches-mv-addr-reg-p (instr) 17 | (and (eq (first instr) :move-addr-to-reg) 18 | (reg-eq-p (move-to instr) (make-reg 1)))) 19 | 20 | (defun matches-op-if-1-p (instr) 21 | (and (vm-if-p instr) 22 | (reg-eq-p (vm-if-reg instr) (make-reg 2)))) 23 | 24 | (defun add-instrs-to-node (hash node instrs) 25 | (multiple-value-bind (other-instrs found-p) (gethash node hash) 26 | (declare (ignore found-p)) 27 | (setf (gethash node hash) (append other-instrs instrs)))) 28 | 29 | (defun get-target-node (op-instr) (addr-num (move-from op-instr))) 30 | 31 | (defun select-node-init (start-instrs) 32 | (declare (optimize (speed 3) (safety 0))) 33 | (let ((hash (make-hash-table)) 34 | (new-start nil) 35 | (ptr nil) 36 | (current start-instrs)) 37 | (loop while (not (null current)) 38 | do (cond 39 | ((at-least-n-p current 4) 40 | (cond 41 | ((and (matches-mv-host-to-reg-p (nth 0 current)) 42 | (matches-mv-addr-reg-p (nth 1 current)) 43 | (matches-op-addr-equal-p (nth 2 current)) 44 | (matches-op-if-1-p (nth 3 current))) 45 | (add-instrs-to-node hash (get-target-node (nth 1 current)) (vm-if-instrs (nth 3 current))) 46 | (setf current (drop-first-n current 4))) 47 | (new-start 48 | (setf (cdr ptr) current 49 | ptr current 50 | current (cdr current) 51 | (cdr ptr) nil)) 52 | (t 53 | (setf new-start current 54 | ptr current 55 | current (cdr current) 56 | (cdr ptr) nil)))) 57 | (t 58 | (cond 59 | (new-start 60 | (setf (cdr ptr) current 61 | current nil)) 62 | (t 63 | (setf new-start current 64 | current nil)))))) 65 | (values hash new-start))) 66 | 67 | (defun make-vm-select-with-rules (hash) 68 | (letret (instr (make-vm-select-node)) 69 | (set-vm-select-hash instr hash))) 70 | 71 | (defun merge-select-instrs (new old) 72 | (if (null old) 73 | new 74 | (merge-vm-select-node new old))) 75 | 76 | (defun optimize-init () 77 | (let ((def (find-init-predicate *definitions*))) 78 | (assert (not (null def))) 79 | (with-definition def (:name init-name) 80 | (let ((init-proc (vm-find init-name))) 81 | (when init-proc 82 | (with-process init-proc (:instrs instrs :process proc) 83 | (multiple-value-bind (hash to-keep) (select-node-init instrs) 84 | (if (= (hash-table-count hash) 0) 85 | (setf (process-instrs proc) to-keep) 86 | (let ((new-instr (make-vm-select-with-rules hash))) 87 | (setf (process-instrs proc) (cons new-instr to-keep)))))))))) 88 | ; do the same for rule code 89 | (let* ((init (first *code-rules*)) 90 | (iterate (second (rule-code init))) 91 | (init-code (iterate-instrs iterate))) 92 | (assert (not (null init-code))) 93 | (multiple-value-bind (hash to-keep1) (select-node-init init-code) 94 | (if (= (hash-table-count hash) 0) 95 | (setf (iterate-instrs iterate) to-keep1) 96 | (let* ((new-instr (make-vm-select-with-rules hash)) 97 | (old-instr (find-if #'vm-select-node-p to-keep1)) 98 | (to-keep (remove old-instr to-keep1))) 99 | (setf new-instr (merge-select-instrs new-instr old-instr)) 100 | (setf (iterate-instrs iterate) `(,(make-vm-remove (make-reg 0)) ,new-instr ,@(remove-if #'(lambda (x) (and (vm-remove-p x) (= 0 (reg-num (vm-remove-reg x))))) to-keep)))))))) 101 | 102 | (defmacro iterate-code ((&key instrs proc) &body body) 103 | (alexandria:with-gensyms (name) 104 | `(do-definitions (:name ,name) 105 | (with-process (vm-find ,name) (:instrs ,instrs :process ,proc) 106 | ,@body)))) 107 | 108 | (defun optimize-return-instr-list (instrs) 109 | (loop for instr-list on instrs 110 | do (let ((instr (first instr-list))) 111 | (case (instr-type instr) 112 | (:iterate 113 | (optimize-return-instr-list (iterate-instrs instr))) 114 | (:if 115 | (optimize-return-instr-list (vm-if-instrs instr))) 116 | (:reset-linear 117 | (optimize-return-instr-list (vm-reset-linear-instrs instr))) 118 | (otherwise 119 | (when (and (instr-is-return-p instr) 120 | (instr-is-return-p (second instr-list))) 121 | ;; remove second return 122 | (setf (rest instr-list) (rest (rest instr-list))))))))) 123 | 124 | (defun optimize-returns () 125 | (iterate-code (:instrs instrs :proc proc) 126 | (declare (ignore proc)) 127 | (optimize-return-instr-list instrs))) 128 | 129 | (defun optimize-code () 130 | (unless *use-optimizations* 131 | (return-from optimize-code nil)) 132 | (when (> (hash-table-count *nodes*) 0) 133 | (optimize-init)) 134 | (optimize-returns)) 135 | 136 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :cl-user) 3 | 4 | (defpackage :cl-meld 5 | (:use :cl :cl-lex :yacc :ieee-floats :cl-csv) 6 | (:import-from :flexi-streams :make-in-memory-output-stream) 7 | (:import-from :arnesi :sharpl-reader) 8 | (:export :comp :meld-compile :meld-compile-exit :meld-compile-list 9 | :snap-stanford-dump)) 10 | 11 | (arnesi:enable-sharp-l) 12 | -------------------------------------------------------------------------------- /print.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (defun print-val-list (vals) 4 | (let ((args (mapcar #'print-val vals)) 5 | (start "")) 6 | (dolist-count (arg args id) 7 | (when (> id 1) 8 | (setf start (concatenate 'string start ", "))) 9 | (setf start (concatenate 'string start arg))) 10 | start)) 11 | 12 | (defun print-val (val &optional (hide-pars nil)) 13 | (cond 14 | ((bool-p val) (tostring "~a" (if (bool-val val) "true" "false"))) 15 | ((var-p val) (tostring "~a" (var-name val))) 16 | ((int-p val) (tostring "~A" (int-val val))) 17 | ((float-p val) (tostring "~A" (float-val val))) 18 | ((host-id-p val) (tostring "host-id")) 19 | ((host-p val) (tostring "host")) 20 | ((thread-id-p val) (tostring "thread-id")) 21 | ((world-p val) (tostring "world")) 22 | ((cpus-p val) "cpus") 23 | ((addr-p val) (tostring "@~a" (addr-num val))) 24 | ((string-constant-p val) (tostring "\"~a\"" (string-constant-val val))) 25 | ((struct-p val) 26 | (tostring ":(~a)" (print-val-list (struct-list val)))) 27 | ((struct-val-p val) (tostring "~a:~a" (print-val (struct-val-var val)) (struct-val-idx val))) 28 | ((convert-float-p val) 29 | (tostring "float(~a)" (print-val (convert-float-expr val)))) 30 | ((cons-p val) 31 | (tostring "cons(~a,~a)" (print-val (cons-head val)) (print-val (cons-tail val)))) 32 | ((tail-p val) 33 | (tostring "tail(~a)" (print-val (tail-list val)))) 34 | ((head-p val) 35 | (tostring "head(~a)" (print-val (head-list val)))) 36 | ((nil-p val) (tostring "nil")) 37 | ((test-nil-p val) 38 | (tostring "test-nil(~a)" (print-val (test-nil-expr val)))) 39 | ((not-p val) 40 | (tostring "not(~a)" (print-val (not-expr val)))) 41 | ((op-p val) 42 | (tostring "~a~a ~a ~a~a" 43 | (if hide-pars "" "(") 44 | (print-val (op-op1 val)) 45 | (op-to-string (op-op val)) 46 | (print-val (op-op2 val)) 47 | (if hide-pars "" ")"))) 48 | ((let-p val) 49 | (tostring "let ~a = ~a in ~a end" (print-val (let-var val)) (print-val (let-expr val)) (print-val (let-body val)))) 50 | ((if-p val) 51 | (tostring "if ~a then ~a else ~a end" (print-val (if-cmp val)) (print-val (if-e1 val)) (print-val (if-e2 val)))) 52 | ((get-constant-p val) 53 | (with-constant (lookup-const (get-constant-name val)) (:expr expr) 54 | (print-val expr))) 55 | ((or (call-p val) (callf-p val)) 56 | (tostring "~a(~a)" (call-name val) (print-val-list (call-args val)))) 57 | ((argument-p val) 58 | (tostring "@arg~a" (argument-id val))) 59 | (t 60 | (error 'expr-invalid-error :text (tostring "Can't print expression ~a" val))))) 61 | 62 | (defun print-args (stream args) 63 | (format stream "(") 64 | (dolist-count (arg args id) 65 | (if (> id 1) 66 | (format stream ", ")) 67 | (format stream "~a" (print-val arg t))) 68 | (format stream ")")) 69 | 70 | (defparameter *current-print-level* 0) 71 | (defparameter *max-print-level* 4) 72 | (defvar *number-of-items-printed* 0) 73 | 74 | (defmacro check-print-level (stream) 75 | `(progn 76 | (when (> *number-of-items-printed* 0) 77 | (format ,stream ", ")) 78 | (incf *number-of-items-printed*) 79 | (cond 80 | ((= *current-print-level* *max-print-level*) 81 | (setf *current-print-level* 0) 82 | (format ,stream "~a~a~a~a" #\Newline #\Tab #\Tab #\Tab)) 83 | (t (incf *current-print-level*))) 84 | *number-of-items-printed*)) 85 | 86 | (defun print-subgoal-modifier (sub def) 87 | (cond 88 | ((is-linear-p def) 89 | (if (subgoal-is-reused-p sub) 90 | "!" 91 | (if (subgoal-has-option-p sub :linear) 92 | "?" 93 | ""))) 94 | (t 95 | "!"))) 96 | 97 | (defun print-subgoals (stream subgoals) 98 | (do-subgoals subgoals (:name name :args args :subgoal sub) 99 | (with-definition (lookup-definition name) (:definition def) 100 | (check-print-level stream) 101 | (format stream "~a~A" (print-subgoal-modifier sub def) name) 102 | (print-args stream args) 103 | (when (subgoal-is-remote-p sub) 104 | (format stream "@~a" (var-name (subgoal-get-remote-dest sub)))) 105 | (when (subgoal-is-thread-p sub) 106 | (format stream "@T")) 107 | ))) 108 | 109 | (defun print-constraints (stream subgoals) 110 | (do-constraints subgoals (:expr expr :id id) 111 | (check-print-level stream) 112 | (format stream "~a" (print-val expr t)))) 113 | 114 | (defun print-assignments (stream subgoals) 115 | (do-assignments subgoals (:var var :expr expr :id id) 116 | (check-print-level stream) 117 | (format stream "~a" (print-val var t)) 118 | (format stream " := ") 119 | (format stream "~a" (print-val expr t)))) 120 | 121 | (defun print-type (typ) 122 | (cond 123 | ((type-int-p typ) "int") 124 | ((type-float-p typ) "float") 125 | ((type-addr-p typ) "addr") 126 | ((type-string-p typ) "string") 127 | ((type-list-p typ) 128 | (let ((sub (type-list-element typ))) 129 | (tostring "list ~a" (print-type sub)))) 130 | (t (error 'expr-invalid-error :text (tostring "print-type does not know how to handle ~a" typ))))) 131 | 132 | (defun print-types (typs) 133 | (reduce #'(lambda (all new) 134 | (let ((typ (print-type new))) 135 | (if (string-equal all "") 136 | typ 137 | (tostring "~a, ~a" all typ)))) 138 | typs :initial-value "")) 139 | 140 | (defmacro with-comma-context (&body body) 141 | `(let ((*number-of-items-printed* 0)) 142 | ,@body)) 143 | 144 | (defmacro with-print-context (&body body) 145 | `(let ((*current-print-level* 0) (*number-of-items-printed* 0)) 146 | ,@body)) 147 | 148 | (defun print-subgoal-body (stream body) 149 | (with-comma-context 150 | (print-subgoals stream body) 151 | (when (has-assignments-p body) 152 | (print-assignments stream body)) 153 | (when (has-constraints-p body) 154 | (print-constraints stream body)))) 155 | 156 | (defun print-var-list (stream vars) 157 | (dolist-count (var vars i) 158 | (when (> i 1) 159 | (format stream ", ")) 160 | (format stream "~a" (print-val var)))) 161 | 162 | (defun print-subgoal-head (stream head) 163 | (with-comma-context 164 | (cond 165 | ((null head) (format stream "1")) 166 | ((clause-head-is-recursive-p head) 167 | (dolist (clause1 head) 168 | (if (> (check-print-level stream) 1) 169 | (format stream "OR ")) 170 | (format stream "(") 171 | (print-clause stream clause1 :end nil) 172 | (format stream ")"))) 173 | (t 174 | (when (has-assignments-p head) 175 | (print-assignments stream head)) 176 | (print-subgoals stream head) 177 | (do-comprehensions head (:right right :left left :variables vars) 178 | (check-print-level stream) 179 | (with-comma-context 180 | (format stream "{") 181 | (print-var-list stream vars) 182 | (format stream " | ") 183 | (print-subgoal-body stream left) 184 | (format stream " | ") 185 | (check-print-level stream) 186 | (print-subgoal-head stream right) 187 | (format stream "}"))) 188 | (do-agg-constructs head (:body body :head0 agg-head0 :head agg-head :vlist vars :specs specs :agg-construct agg) 189 | (check-print-level stream) 190 | (format stream "[") 191 | (do-agg-specs specs (:var to :op op :id id) 192 | (when (> id 0) 193 | (format stream ", ")) 194 | (format stream "~(~a~) => ~A" op (print-val to))) 195 | (when vars 196 | (format stream " | ") 197 | (print-var-list stream vars)) 198 | (format stream " | ") 199 | (check-print-level stream) 200 | (with-comma-context 201 | (print-subgoal-body stream body)) 202 | (when agg-head0 203 | (format stream " | ") 204 | (print-subgoal-head stream agg-head0)) 205 | (when head 206 | (format stream " | ") 207 | (print-subgoal-head stream agg-head)) 208 | (format stream "]")) 209 | (do-conditionals head (:cmp cmp :term1 terms1 :term2 terms2) 210 | (check-print-level stream) 211 | (format stream "if ~a then " (print-val cmp t)) 212 | (with-comma-context 213 | (print-subgoal-head stream terms1)) 214 | (check-print-level stream) 215 | (when terms2 216 | (format stream " otherwise ") 217 | (print-subgoal-head stream terms2)) 218 | (format stream " end")) 219 | (do-exists head (:var-list vars :body body) 220 | (check-print-level stream) 221 | (format stream "exists ") 222 | (print-var-list stream vars) 223 | (format stream ". (") 224 | (with-comma-context 225 | (print-subgoals stream body)) 226 | (format stream ")")))))) 227 | 228 | (defun print-clause (stream clause &key (end t)) 229 | (with-clause clause (:head head :body body) 230 | (with-print-context 231 | (print-subgoal-body stream body) 232 | (format stream " -o ") 233 | (print-subgoal-head stream head) 234 | (when end 235 | (format stream "."))))) 236 | 237 | (defun clause-to-string (clause) 238 | (with-output-to-string (str) 239 | (print-clause str clause))) 240 | 241 | (defun print-program () 242 | (format t "I found the following definitions:~%") 243 | (do-definitions (:name name :types typs) 244 | (format t "~A [~A]~%" name (print-types typs))) 245 | (format t "I found the following axioms:~%") 246 | (do-all-var-axioms (:clause clause) 247 | (print-clause t clause) 248 | (format t "~%")) 249 | (format t "I found the following rules:~%") 250 | (do-rules (:clause clause :id id) 251 | (format t "Clause ~A: " id) 252 | (print-clause t clause) 253 | (format t "~%"))) 254 | -------------------------------------------------------------------------------- /scripts/Makefile: -------------------------------------------------------------------------------- 1 | 2 | TARGET = /usr/local 3 | 4 | install: 5 | mkdir -p $(TARGET)/bin 6 | install --mode=555 meld-compile-file $(TARGET)/bin/ 7 | install --mode=555 meld-compile-directory $(TARGET)/bin/ 8 | install --mode=555 meld-compile-from-directory $(TARGET)/bin/ 9 | -------------------------------------------------------------------------------- /scripts/README: -------------------------------------------------------------------------------- 1 | Example: 2 | 3 | compile-from-directory code $PWD/progs/pagerank_grid_10_25.meld 4 | -------------------------------------------------------------------------------- /scripts/meld-compile-directory: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | DIR=$1 4 | TARGET=$2 5 | 6 | if [ -z "$DIR" ]; then 7 | echo "No source directory provided" 8 | exit 1 9 | fi 10 | if [ -z "$TARGET" ]; then 11 | echo "No target directory provided" 12 | exit 1 13 | fi 14 | 15 | should_be_recompiled() 16 | { 17 | if [ "$1" -nt "$2" ]; then 18 | return 0 19 | else 20 | if [ $(du -k $1 | cut -f1) -gt 50 ]; then 21 | return 1 22 | fi 23 | for subfile in $(grep 'include #' $1|awk -F '#' '{print $2}'); do 24 | filepath="$dir/$subfile" 25 | if should_be_recompiled "`dirname $1`/$subfile" $2; then 26 | return 0 27 | fi 28 | done 29 | fi 30 | return 1 31 | } 32 | 33 | ARG="" 34 | for file in $PWD/$DIR/*.meld; do 35 | base=$(basename $file .meld) 36 | target="$TARGET/$base.m" 37 | if should_be_recompiled $file $target; then 38 | ARG="$ARG $file $PWD/$TARGET/$base" 39 | echo ">> Compiling $DIR/$base.meld to $target" 40 | fi 41 | done 42 | if [ -z "$ARG" ]; then 43 | echo ">> Files are up-to-date" 44 | else 45 | meld-compile-file $ARG 46 | fi 47 | -------------------------------------------------------------------------------- /scripts/meld-compile-file: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #| 3 | exec sbcl --noinform --dynamic-space-size 4096 --script "$0" $@ 4 | |# 5 | 6 | 7 | (defvar *params* (rest sb-ext:*posix-argv*)) 8 | 9 | (when (null *params*) 10 | (format t "Usage: compile-file ...~%") 11 | (quit)) 12 | 13 | (format t "==> Launching the Lisp system...~%") 14 | (format t "==> Loading CL-Meld...~%") 15 | #-quicklisp 16 | (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" 17 | (user-homedir-pathname)))) 18 | (when (probe-file quicklisp-init) 19 | (load quicklisp-init))) 20 | 21 | (ql:quickload "cl-meld" :verbose t) 22 | 23 | (let ((ls (loop for (in . (out . nil)) on *params* by #'cddr 24 | collect (list in out)))) 25 | (sb-ext:quit :unix-status (if (cl-meld:meld-compile-list ls) 0 1))) 26 | -------------------------------------------------------------------------------- /scripts/meld-compile-from-directory: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | TARGET=${1} 4 | shift 5 | FILES="${*}" 6 | 7 | if [ -z "$TARGET" ]; then 8 | echo "No target directory provided" 9 | exit 1 10 | fi 11 | if [ -z "$FILES" ]; then 12 | echo "No input files provided" 13 | exit 1 14 | fi 15 | 16 | ARG="" 17 | for file in $FILES; do 18 | if [ ! -f "${file}" ]; then 19 | continue 20 | fi 21 | base=`basename $file .meld` 22 | ARG="$ARG $file $PWD/$TARGET/$base" 23 | done 24 | meld-compile-file $ARG 25 | -------------------------------------------------------------------------------- /scripts/standalone.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PROGRAM_DIR=$(dirname $PWD/$0) 4 | TARGET=compile 5 | LISP_MELD=$(realpath "$PROGRAM_DIR/..") 6 | mkdir -p $TARGET || exit 1 7 | cd $TARGET || exit 1 8 | if [ ! -f quicklisp.lisp ]; then 9 | wget http://beta.quicklisp.org/quicklisp.lisp || exit 1 10 | fi 11 | if [ ! -f setup.lisp ]; then 12 | sbcl --no-userinit --load quicklisp.lisp < (hash-table-count reached) (* 2 n-targets)) 204 | (return-from aux nil)) 205 | (multiple-value-bind (ls found-p) (gethash x edges) 206 | (when found-p 207 | (loop for ed being the elements of ls 208 | do (multiple-value-bind (ig found-p) (gethash ed reached) 209 | (unless found-p 210 | (unless (aux ed) 211 | (return-from aux nil))))))) 212 | t)) 213 | (aux n) 214 | (get-first-n (shuffle-list (loop for key being the hash-keys of reached collect key) rnd) 215 | n-targets)))) 216 | 217 | (defmethod data-input-node-axioms ((obj snap-search-data) (n integer)) 218 | (let* ((facts (snap-search-build-edges obj n)) 219 | (rnd (sb-ext:seed-random-state 0)) 220 | (n-nodes (hash-table-count (snap-nodes obj)))) 221 | (push (make-subgoal "value" (list (make-int n :type-int))) facts) 222 | (when (gethash n (snap-search-source-nodes obj)) 223 | (let (targets 224 | (ls (make-nil)) 225 | (n-targets (truncate (* n-nodes (/ (coerce (snap-search-fraction obj) 'float) 100))))) 226 | (when (= (mod n 5) 0) 227 | (setf targets (snap-search-find-path n (snap-edges obj) n-targets rnd))) 228 | (unless targets 229 | (loop while (< (length targets) n-targets) 230 | do (let ((id (random n-nodes rnd))) 231 | (unless (member id targets) 232 | (push id targets))))) 233 | (loop for id in targets 234 | do (setf ls (make-cons (make-int id :type-int) ls))) 235 | (push (make-subgoal "search" (list (make-int (snap-search-id obj) :type-int) ls)) facts) 236 | (incf (snap-search-id obj)))) 237 | facts)) 238 | -------------------------------------------------------------------------------- /stratification.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :cl-meld) 3 | 4 | (define-condition stratification-error (error) 5 | ((text :initarg :text :reader text))) 6 | 7 | (defvar *strat-ctx* nil) 8 | (defvar *strat-routes* nil) 9 | (defvar *current-strat-level* 0) 10 | 11 | (defun clause-edge-fact-p (routes) 12 | #L(let ((head-subgoal (first (clause-head !1)))) 13 | (some #L(subgoal-matches-def-p head-subgoal !1) routes))) 14 | 15 | (defun get-non-routes (defs) 16 | (remove-if #'is-route-p defs)) 17 | 18 | (defun make-stratification-ctx () (list)) 19 | (defun push-strata (def level) 20 | (definition-set-strata def level) 21 | (push def *strat-ctx*)) 22 | 23 | (defun subgoal-matches-any-def-p (sub &optional (ctx *strat-ctx*)) 24 | (some #L(subgoal-matches-def-p sub !1) ctx)) 25 | 26 | (defun can-fire-clause-p (clause &optional (ctx *strat-ctx*)) 27 | (when (every #'(lambda (sub) (subgoal-matches-any-def-p sub ctx)) 28 | (get-subgoals (clause-body clause))) 29 | (clause-head clause))) 30 | 31 | (defun is-aggregate-head-p (head) 32 | (when (one-elem-p head) 33 | (let ((subgoal (first head))) 34 | (let ((def (lookup-subgoal-definition subgoal))) 35 | (definition-aggregate-p def))))) 36 | 37 | (defun is-aggregate-clause-p (clause) 38 | (let ((head (clause-head clause))) 39 | (is-aggregate-head-p head))) 40 | 41 | (defun subgoal-not-generated-by-p (subgoal) 42 | #'(lambda (clause) 43 | (let ((head (clause-head clause))) 44 | (every #L(not (subgoal-match-p subgoal !1)) head)))) 45 | 46 | (defun heads-not-in-p (not-fire-clauses head) 47 | (every #L(every (subgoal-not-generated-by-p !1) not-fire-clauses) head)) 48 | 49 | (defun select-fired-rules (will-fire not-fire) 50 | (filter #'(lambda (fire-clause) 51 | (let ((head (clause-head fire-clause))) 52 | (heads-not-in-p not-fire head))) 53 | will-fire)) 54 | 55 | (defun select-if-aggregate (clauses) 56 | (split-mult-return #'is-aggregate-clause-p clauses)) 57 | 58 | (defun get-head-subgoal (clause) (first (clause-head clause))) 59 | (defun get-head-subgoal-name (clause) (subgoal-name (get-head-subgoal clause))) 60 | 61 | (defun group-clauses-by-head (clauses) 62 | (let ((hash (make-hash-table :test #'equal))) 63 | ;(format t "group clauses ~a~%" clauses) 64 | (loop for clause in clauses 65 | do (let ((name (get-head-subgoal-name clause))) 66 | (multiple-value-bind (ls found-p) (gethash name hash) 67 | (declare (ignore found-p)) 68 | ;(format t "ADD ~a~%" name) 69 | (setf (gethash name hash) 70 | (cons clause ls))))) 71 | (iterate-hash (hash name clauses :op collect) clauses))) 72 | 73 | (defun local-clause-p (clause) (not (clause-has-tagged-option-p clause :route))) 74 | 75 | (defun is-init-subgoal-p (subgoal) (is-init-p (lookup-subgoal-definition subgoal))) 76 | 77 | (defun is-init-clause-p (clause) 78 | "Given a clause tells you if that clause is generated during init." 79 | (with-clause clause (:body body) 80 | (and (one-elem-p body) 81 | (is-init-subgoal-p (first body))))) 82 | 83 | (defun body-generated-by-all-p (clause) 84 | (with-clause clause (:body body) 85 | (every #L(definition-has-option-p (lookup-subgoal-definition !1) :generated-by-all) 86 | (get-subgoals body)))) 87 | 88 | (defun clause-generated-by-all-p (clause) 89 | "Tells you if a clause will be fired by all nodes." 90 | (or (is-init-clause-p clause) 91 | (body-generated-by-all-p clause))) 92 | 93 | (defun generated-by-all-p (clauses) 94 | (some #'clause-generated-by-all-p clauses)) 95 | 96 | (defun set-generated-by-all (def) 97 | (definition-add-option def :generated-by-all)) 98 | 99 | (defun is-unique-aggregate-p (def) 100 | "Tells if aggregate has only one value (that is, argument with aggregate is the first one)" 101 | (assert (definition-p def)) 102 | (with-definition def (:types typs) 103 | (assert (>= (length typs) 1)) 104 | (aggregate-p (first typs)))) 105 | 106 | (defun process-unrecursive-aggs (agg-clauses) 107 | (loop for clauses in agg-clauses 108 | for def = (lookup-definition (get-head-subgoal-name (first clauses))) 109 | do (push-strata def *current-strat-level*) 110 | do (when (every #'local-clause-p clauses) 111 | (definition-set-local-agg def)) 112 | do (when (generated-by-all-p clauses) 113 | (set-generated-by-all def)))) 114 | 115 | (defun process-unrecursive-non-agg-clause (clause) 116 | (let ((by-all (clause-generated-by-all-p clause))) 117 | (with-clause clause (:head head) 118 | (do-subgoals head (:subgoal sub) 119 | (let ((def (lookup-subgoal-definition sub))) 120 | (push-strata def *current-strat-level*) 121 | (if by-all 122 | (set-generated-by-all def))))))) 123 | 124 | (defun process-unrecursive-non-aggs (clauses) 125 | (loop for clause in clauses 126 | do (process-unrecursive-non-agg-clause clause))) 127 | 128 | (defun get-head-definitions (clauses) 129 | (with-ret defs 130 | (do-clauses clauses (:head head) 131 | (do-subgoals head (:subgoal sub :name name) 132 | (let ((def (lookup-definition name defs))) 133 | (unless def 134 | (push (lookup-subgoal-definition sub) defs))))))) 135 | 136 | (defun definition-has-stage-argument (def) 137 | (with-definition def (:types typs) 138 | (and (>= (length typs) 1) 139 | (type-int-p (first typs))))) 140 | 141 | (defun find-subgoals-by-definitions (body-head defs) 142 | (filter #'(lambda (sub) 143 | (some #L(subgoal-matches-def-p sub !1) defs)) 144 | (get-subgoals body-head))) 145 | 146 | (defun find-subgoals-by-definition (body-head def) 147 | (with-definition def (:name name) 148 | (filter (subgoal-by-name name) (get-subgoals body-head)))) 149 | 150 | (defun is-plus-1-arg-p (arg) 151 | (and (op-p arg) 152 | (let ((op1 (op-op1 arg)) 153 | (op2 (op-op2 arg))) 154 | (or 155 | (and (var-p op1) 156 | (int-p op2) 157 | (= (int-val op2) 1)) 158 | (and (int-p op1) 159 | (= (int-val op1) 1) 160 | (var-p op2)))))) 161 | 162 | (defun get-iteration-var (arg) 163 | (cond 164 | ((is-plus-1-arg-p arg) 165 | (cond 166 | ((var-p (op-op1 arg)) (op-op1 arg)) 167 | ((var-p (op-op2 arg)) (op-op2 arg)) 168 | (t nil))) 169 | ((var-p arg) arg) 170 | (t nil))) 171 | 172 | (defun is-plus-1-arg-equal-p (arg var) 173 | (and (op-p arg) 174 | (let ((op1 (op-op1 arg)) 175 | (op2 (op-op2 arg))) 176 | (or 177 | (and (var-p op1) 178 | (var-eq-p op1 var) 179 | (int-p op2) 180 | (= (int-val op2) 1)) 181 | (and (int-p op1) 182 | (= (int-val op1) 1) 183 | (var-p op2)))))) 184 | 185 | (defun uses-iter-var-p (arg var) 186 | (or (is-plus-1-arg-equal-p arg var) 187 | (and (var-p arg) 188 | (var-eq-p arg var)))) 189 | 190 | (defun find-assignment-or-constraint (body var) 191 | (let* ((assignments (get-assignments body)) 192 | (found (find-if #L(var-eq-p (assignment-var !1) var) assignments))) 193 | (if found 194 | (assignment-expr found) 195 | (let ((op-expr (find-assignment-constraints-expr body var))) 196 | (when op-expr 197 | (op-op2 (first op-expr))))))) 198 | 199 | (defun dereference-variable (arg body) 200 | (map-expr #'var-p 201 | #'(lambda (var) 202 | (let ((expr (find-assignment-or-constraint body var))) 203 | (if expr 204 | (dereference-variable expr body) 205 | var))) 206 | arg)) 207 | 208 | (defun dereference-variables (args body) 209 | (mapcar #L(dereference-variable !1 body) args)) 210 | 211 | (defun all-first-variables (subgoals) 212 | (mapcar #L(first (subgoal-args !1)) subgoals)) 213 | 214 | (defun get-stage-variables (subgoals body) 215 | (dereference-variables (all-first-variables subgoals) body)) 216 | 217 | (defun is-x-rule-p (defs) 218 | #'(lambda (clause) 219 | (with-clause clause (:body body :head head) 220 | (let* ((subs-head (find-subgoals-by-definitions head defs)) 221 | (subs-body (find-subgoals-by-definitions body defs)) 222 | (all (append subs-head subs-body)) 223 | (vars-iter (get-stage-variables all body))) 224 | (and (every #'var-p vars-iter) 225 | (all-equal-p vars-iter :test #'var-eq-p)))))) 226 | 227 | (defun is-y-rule-p (defs) 228 | #'(lambda (clause) 229 | (with-clause clause (:body body :head head) 230 | (let* ((subs-head (find-subgoals-by-definitions head defs)) 231 | (subs-body (find-subgoals-by-definitions body defs)) 232 | (vars-head (get-stage-variables subs-head body)) 233 | (vars-body (get-stage-variables subs-body body))) 234 | (when (and vars-head vars-body) 235 | (let ((iter-var (get-iteration-var (first vars-body)))) 236 | (and (every #L(is-plus-1-arg-equal-p !1 iter-var) vars-head) 237 | (every #L(uses-iter-var-p !1 iter-var) vars-body)))))))) 238 | 239 | (defun is-start-rule-p (defs) 240 | #'(lambda (clause) 241 | (with-clause clause (:body body :head head) 242 | (let* ((subs-head (find-subgoals-by-definitions head defs)) 243 | (subs-body (find-subgoals-by-definitions body defs)) 244 | (stages-head (get-stage-variables subs-head body))) 245 | (and (null subs-body) 246 | (every #'int-p stages-head)))))) 247 | 248 | (defun find-x-rules (clauses defs) 249 | (filter (is-x-rule-p defs) clauses)) 250 | 251 | (defun find-y-rules (clauses defs) 252 | (filter (is-y-rule-p defs) clauses)) 253 | 254 | (defun find-start-rules (clauses defs) 255 | (filter (is-start-rule-p defs) clauses)) 256 | 257 | (defun find-stable-arguments (def clause) 258 | "From the clause 'clause' finds the arguments that stay the same when a new 'def' fact is instantiated. 259 | This returns a list of arguments as integers." 260 | (with-definition def (:num-args n-args) 261 | (with-clause clause (:body body :head head) 262 | (let* ((subs-head (find-subgoals-by-definition head def)) 263 | (subs-body (find-subgoals-by-definition body def)) 264 | (all (append subs-head subs-body))) 265 | (if (= (length all) 1) 266 | (list 1) 267 | (let* ((args-except-first (mapcar #L(rest (subgoal-args !1)) all)) ;; remove stage argument 268 | (args (mapcar #L(dereference-variables !1 body) args-except-first)) 269 | (ls (list 1))) ;; initial list of equal variables 270 | (loop for i from 1 upto (1- n-args) 271 | do (let ((this-args (mapcar #L(nth (1- i) !1) args))) 272 | (when (all-equal-p this-args :test #'expr-eq-p) 273 | ;(format t "~a ARE EQUAL ~%" (1+ i)) 274 | (push-end (1+ i) ls)))) 275 | ;(format t "~a all ~a~%" name args) 276 | ls)))))) 277 | 278 | (defun sort-clauses-by-occurrences (clauses name) 279 | (sort clauses #'> :key #L(clause-number-of-occurrences !1 name))) 280 | 281 | (defun add-delete-options-to-clause (def clause args) 282 | (assert (ordered-p args)) 283 | (with-definition def (:name name) 284 | (clause-add-delete clause name args) 285 | ;(format t "deleting ~a ~a using ~a~%" name args clause) 286 | )) 287 | 288 | (defun add-delete-options (def clauses) 289 | (with-definition def (:name name) 290 | ;(format t "def ~a -> ~a~%" name clauses) 291 | (let* ((head-clauses (filter #L(and (clause-head-matches-subgoal-p !1 name) 292 | (not (clause-is-remote-p !1))) clauses)) 293 | (body-clauses (filter #L(clause-body-matches-subgoal-p !1 name) clauses)) 294 | (all-stables (mapcar #L(find-stable-arguments def !1) head-clauses)) 295 | (inter-stables (intersection-all all-stables))) 296 | ;(format t "def ~a ~a~%" name inter-stables) 297 | (assert body-clauses) 298 | (add-delete-options-to-clause def 299 | (first (sort-clauses-by-occurrences body-clauses name)) 300 | (if inter-stables inter-stables '(1)))))) 301 | 302 | (defun find-clause-clique (clauses) 303 | (let* ((defs (get-head-definitions clauses)) 304 | (has-stage-argument (every #'definition-has-stage-argument defs))) 305 | (unless has-stage-argument 306 | (format t "Some definitions fail to have a stage argument!~%") 307 | (return-from find-clause-clique nil)) 308 | (let* ((x-rules (find-x-rules clauses defs)) 309 | (y-rules (find-y-rules clauses defs)) 310 | (start-rules (find-start-rules clauses defs)) 311 | (total-clique (+ (length x-rules) (length y-rules) (length start-rules)))) 312 | (unless (= (length clauses) total-clique) 313 | (format t "Cannot partition clauses into x-rules and y-rules!~%") 314 | (return-from find-clause-clique nil)) 315 | (when (or (null x-rules) (null y-rules)) 316 | (return-from find-clause-clique nil)) 317 | (printdbg "Found a XY-clique with ~a clauses!" total-clique) 318 | (loop for def in defs 319 | do (push-strata def *current-strat-level*)) 320 | (incf *current-strat-level*) 321 | ;; Add delete stuff 322 | (loop for def in defs 323 | do (with-definition def (:name name) 324 | (let ((affected-clauses (filter #L(and (clause-matches-subgoal-p !1 name)) 325 | (append x-rules y-rules)))) 326 | (add-delete-options def affected-clauses)))) 327 | clauses))) 328 | 329 | (defun stratification-loop (clauses) 330 | (multiple-value-bind (will-fire not-fire) (split-mult-return #'can-fire-clause-p clauses) 331 | (let ((will-really-fire (select-fired-rules will-fire not-fire))) 332 | (if (null will-really-fire) 333 | (progn 334 | (let ((clique (find-clause-clique clauses))) 335 | (remove-all clauses clique))) 336 | (multiple-value-bind (agg-clauses not-agg) (select-if-aggregate will-really-fire) 337 | (when agg-clauses 338 | (let ((grouped-agg (group-clauses-by-head agg-clauses))) 339 | (process-unrecursive-aggs grouped-agg))) 340 | (process-unrecursive-non-aggs not-agg) 341 | (remove-all clauses will-really-fire)))))) 342 | 343 | (defun mark-unstratified-predicates () 344 | ; find new priorities before computing the priority list 345 | (find-priorities) 346 | (let ((priorities (assign-priorities *current-strat-level* (filter #'priority-p *directives*)))) 347 | (dolist (prio priorities) 348 | (let ((name (first prio)) 349 | (priority (rest prio))) 350 | (setf *current-strat-level* (max *current-strat-level* priority)) 351 | (push-strata (lookup-definition name) priority))) 352 | (do-definitions (:definition def) 353 | (unless (definition-has-tagged-option-p def :strat) 354 | (push-strata def *current-strat-level*))))) 355 | 356 | (defun do-strat-loop (clauses) 357 | (incf *current-strat-level*) 358 | (when (null clauses) 359 | (mark-unstratified-predicates) 360 | (return-from do-strat-loop nil)) 361 | (let ((remain (stratification-loop clauses))) 362 | (cond 363 | ((equal remain clauses) 364 | (warn "Could not stratify everything") 365 | (mark-unstratified-predicates)) 366 | (t 367 | (do-strat-loop remain))))) 368 | 369 | (defmacro with-stratification-context ((routes clauses) &body body) 370 | `(let* ((*strat-routes* (get-routes)) 371 | (*current-strat-level* 0) 372 | (*strat-ctx* (make-stratification-ctx)) 373 | (,routes *strat-routes*) 374 | (,clauses (remove-if (clause-edge-fact-p *strat-routes*) *clauses*))) 375 | ,@body)) 376 | 377 | (defun detect-cycles-table (visited edges n origin) 378 | (multiple-value-bind (ls found-p) (gethash n edges) 379 | (dolist (neighbor ls) 380 | (when (string-equal neighbor origin) 381 | (let ((def (lookup-definition origin))) 382 | (definition-set-cyclical def)) 383 | (return-from detect-cycles-table nil)) 384 | (multiple-value-bind (vis found-p) (gethash neighbor visited) 385 | (when (eq vis :unvisited) 386 | (setf (gethash neighbor visited) :visited) 387 | (detect-cycles-table visited edges neighbor origin) 388 | (setf (gethash neighbor visited) :unvisited)))))) 389 | 390 | (defun find-cycles () 391 | (let ((table (make-hash-table :test 'equal))) 392 | (do-rules (:clause clause) 393 | (when (clause-is-persistent-p clause) 394 | (with-clause clause (:body body :head head) 395 | (do-subgoals body (:name body-name) 396 | (multiple-value-bind (value found-p) (gethash body-name table) 397 | (do-subgoals head (:name head-name) 398 | (unless (has-test-elem-p value head-name #'string-equal) 399 | (push head-name value))) 400 | (setf (gethash body-name table) value)))))) 401 | (let ((visited (make-hash-table :test 'equal))) 402 | (loop for key being the hash-keys of table 403 | do (setf (gethash key visited) :unvisited)) 404 | (loop for key being the hash-keys of table 405 | do (progn 406 | (loop for key being the hash-keys of table 407 | do (setf (gethash key visited) :unvisited)) 408 | (detect-cycles-table visited table key key)))))) 409 | 410 | (defun stratify () 411 | (find-cycles) 412 | (with-stratification-context (routes clauses) 413 | (dolist (rout routes) 414 | (set-generated-by-all rout) 415 | (push-strata rout *current-strat-level*)) 416 | (let ((init-def (find-init-predicate *definitions*))) 417 | (set-generated-by-all init-def) 418 | (push-strata init-def *current-strat-level*)) 419 | (if *use-stratification* 420 | (do-strat-loop clauses) 421 | (progn 422 | (incf *current-strat-level*) 423 | (mark-unstratified-predicates))))) 424 | -------------------------------------------------------------------------------- /topology.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (defun node-used-id (mapping-set id) 4 | (gethash id mapping-set)) 5 | 6 | (defun add-mapping (mapping-set node map) 7 | (setf (gethash node mapping-set) map)) 8 | 9 | (defun has-mapping-p (mapping-set node) 10 | (multiple-value-bind (x found-p) (gethash node mapping-set) 11 | (declare (ignore x)) 12 | found-p)) 13 | 14 | (defun make-mapping-set () 15 | (make-hash-table :test #'eq)) 16 | 17 | (defun number-of-nodes (nodes) (hash-table-count nodes)) 18 | 19 | (defmacro iterate-nodes ((fake real nodes) &body body) 20 | (alexandria:with-gensyms (ls) 21 | `(let ((,ls (loop for value being the hash-values of ,nodes 22 | using (hash-key key) 23 | collect (cons value key)))) 24 | (loop for (,fake . ,real) in (sort ,ls #'< :key #'car) 25 | do ,@body)))) 26 | 27 | (defun flip-nodes (hash expr) 28 | (transform-expr #'addr-p #'(lambda (expr) 29 | (setf (addr-num expr) (node-used-id hash (addr-num expr))) 30 | (values nil :stop)) 31 | expr)) 32 | 33 | (defun link-subgoal-p (subgoal routes) 34 | (with-subgoal subgoal (:name name :args args) 35 | (unless (some #L(equal name !1) routes) 36 | (return-from link-subgoal-p nil)) 37 | (some #'addr-p (rest args)))) 38 | 39 | (defun get-link-info (subgoal) 40 | (with-subgoal subgoal (:args args) 41 | (list (addr-num (first args)) 42 | (addr-num (find-if #'addr-p (rest args)))))) 43 | 44 | (defun add-edge-to-set (hash info) 45 | (let ((from (first info)) 46 | (to (second info))) 47 | ;(format t "from ~a to ~a~%" from to) 48 | (setf (gethash from hash) (cons to (gethash from hash))))) 49 | 50 | (defun get-neighbors-from-set (hash from) 51 | (multiple-value-bind (ls found-p) (gethash from hash) 52 | (when found-p 53 | (remhash from hash) 54 | ls))) 55 | 56 | (defun make-edge-set () 57 | (make-hash-table :test #'eq)) 58 | 59 | (defun find-edge-set (routes) 60 | (letret (hash (make-edge-set)) 61 | (do-node-const-axioms (:subgoal subgoal) 62 | (when (link-subgoal-p subgoal routes) 63 | (add-edge-to-set hash (get-link-info subgoal)))))) 64 | 65 | (defun empty-edge-set-p (edge-set) (zerop (hash-table-count edge-set))) 66 | (defun filter-visited-nodes (ls node-set) (filter #L(in-hash-set-p node-set !1) ls)) 67 | 68 | (defun get-random-node-from-node-set (node-set) 69 | (do-hash-set (node node-set) 70 | (return-from get-random-node-from-node-set node))) 71 | 72 | (defun aux-graph-has-cycles-p (edge-set node-set &optional (queue (list))) 73 | (when (find-if #L(not (in-hash-set-p node-set !1)) queue) 74 | (return-from aux-graph-has-cycles-p t)) 75 | (cond 76 | ((and (empty-edge-set-p edge-set) 77 | (null queue)) 78 | nil) 79 | (t 80 | (unless queue 81 | (push (get-random-node-from-node-set node-set) queue)) 82 | (unless queue 83 | (return-from aux-graph-has-cycles-p nil)) 84 | (let* ((node (pop queue)) 85 | (new-edges (get-neighbors-from-set edge-set node))) 86 | (remove-hash-set node-set node) 87 | (aux-graph-has-cycles-p edge-set node-set (append queue new-edges)))))) 88 | 89 | (defun graph-has-cycles-p () 90 | (aux-graph-has-cycles-p (find-edge-set (get-route-names)) (create-hash-set *nodes*))) 91 | 92 | (defun bfs-ordering (edge-set node-set &key (mapping-set (make-mapping-set)) (queue (list)) (count 0)) 93 | (cond 94 | ((empty-edge-set-p edge-set) 95 | (do-hash-set (node node-set) ; add remaining nodes 96 | (add-mapping mapping-set node count) 97 | (incf count)) 98 | mapping-set) 99 | (t 100 | (setf queue (filter-visited-nodes queue node-set)) 101 | (unless queue 102 | (unless (zerop (hash-table-count node-set)) 103 | (push (get-random-node-from-node-set node-set) queue))) 104 | (unless queue 105 | (return-from bfs-ordering mapping-set)) 106 | (let* ((node (pop queue)) 107 | (new-edges (get-neighbors-from-set edge-set node))) 108 | (add-mapping mapping-set node count) 109 | (remove-hash-set node-set node) 110 | (bfs-ordering edge-set node-set 111 | :mapping-set mapping-set 112 | :queue (append queue new-edges) 113 | :count (1+ count)))))) 114 | 115 | (defun naive-ordering (nodes &key (start-count 0) (mapping (make-mapping-set))) 116 | (loop for node in nodes 117 | for count = start-count then (1+ count) 118 | do (add-mapping mapping node count)) 119 | mapping) 120 | 121 | (defun in-file-ordering (nodes &key (mapping (make-mapping-set))) 122 | (let ((max-node 0)) 123 | (loop for node in nodes 124 | do (add-mapping mapping node node) 125 | do (when (> node max-node) 126 | (setf max-node node))) 127 | (loop for i from 0 to max-node 128 | do (unless (has-mapping-p mapping i) 129 | (add-mapping mapping i i)))) 130 | mapping) 131 | 132 | (defun random-ordering (nodes &key (start-count 0) (mapping (make-mapping-set))) 133 | (naive-ordering (shuffle-list nodes) :start-count start-count :mapping mapping)) 134 | 135 | (defun print-mapping (mapping-set) 136 | (iterate-nodes (fake real mapping-set) 137 | (format t "REAL: ~a FAKE: ~a~%" real fake))) 138 | 139 | (defun is-constant-node-list-p (ls) 140 | (cond 141 | ((nil-p ls) t) 142 | ((cons-p ls) 143 | (and (addr-p (cons-head ls)) 144 | (is-constant-node-list-p (cons-tail ls)))))) 145 | 146 | (defun get-constant-list-addrs (ls) 147 | (cond 148 | ((nil-p ls) nil) 149 | ((cons-p ls) 150 | (cons (addr-num (cons-head ls)) 151 | (get-constant-list-addrs (cons-tail ls)))) 152 | (t (assert nil)))) 153 | 154 | (defun build-initial-mapping-set (addrs total) 155 | (letret (mapping (make-mapping-set)) 156 | (loop for i from 0 upto (1- total) 157 | for node in addrs 158 | do (add-mapping mapping node i)))) 159 | 160 | (defun do-topology-ordering () 161 | (setf *nodes* (reverse *nodes*)) 162 | (let* ((found (find-if #'priority-cluster-p *directives*)) 163 | (ordering-type (if found (priority-cluster-type found) *ordering-type*))) 164 | (case ordering-type 165 | (:naive (naive-ordering *nodes*)) 166 | (:random (random-ordering *nodes*)) 167 | (:in-file (in-file-ordering *nodes*)) 168 | (:breadth (let ((edge-set (find-edge-set (get-route-names))) 169 | (node-set (create-hash-set *nodes*))) 170 | (bfs-ordering edge-set node-set))) 171 | (otherwise (assert nil))))) 172 | 173 | (defun call-data-input (input) 174 | (printdbg "Reading input file ~A..." (data-input-file input)) 175 | (cond 176 | ((string-equal (data-input-template input) "stanford-snap") 177 | (let ((ret (snap-file-read (data-input-file input)))) 178 | (setf *nodes* (data-input-nodes ret)) 179 | ret)) 180 | ((string-equal (data-input-template input) "stanford-sssp-snap") 181 | (let ((ret (snap-sssp-file-read (data-input-file input)))) 182 | (setf *nodes* (data-input-nodes ret)) 183 | ret)) 184 | ((string-equal (data-input-template input) "stanford-snap-undirected") 185 | (let ((ret (snap-undirected-file-read (data-input-file input)))) 186 | (setf *nodes* (data-input-nodes ret)) 187 | ret)) 188 | ((string-equal (data-input-template input) "stanford-snap-undirected") 189 | (let ((ret (snap-undirected-file-read (data-input-file input)))) 190 | (setf *nodes* (data-input-nodes ret)) 191 | ret)) 192 | ((string-equal (data-input-template input) "stanford-snap-pagerank") 193 | (let ((ret (snap-pagerank-file-read (data-input-file input)))) 194 | (setf *nodes* (data-input-nodes ret)) 195 | ret)) 196 | ((string-equal (data-input-template input) "stanford-snap-basic") 197 | (let ((ret (snap-basic-file-read (data-input-file input)))) 198 | (setf *nodes* (data-input-nodes ret)) 199 | ret)) 200 | ((string-equal (data-input-template input) "stanford-snap-search") 201 | (let ((args (data-input-args input))) 202 | (unless (= (length args) 2) 203 | (assert nil)) 204 | (let ((ret (snap-search-file-read (data-input-file input) (parse-integer (first args)) (parse-integer (second args))))) 205 | (setf *nodes* (data-input-nodes ret)) 206 | ret))) 207 | (t (assert nil)))) 208 | 209 | (defun optimize-topology () 210 | (let ((mapping (do-topology-ordering))) 211 | ;(print-mapping mapping) 212 | (setf *nodes* mapping) 213 | ;(loop for key being the hash-keys of mapping 214 | ; using (hash-value value) 215 | ; do (format t "The value associated with the key ~S is ~S~%" key value)) 216 | (do-all-var-axioms (:clause clause) 217 | (flip-nodes mapping clause)) 218 | (do-all-const-axioms (:subgoal subgoal) 219 | (flip-nodes mapping subgoal)) 220 | (do-constant-list *consts* (:constant c) 221 | (flip-nodes mapping c)) 222 | (do-rules (:clause clause) 223 | (flip-nodes mapping clause))) 224 | (let ((data-input (find-data-input))) 225 | (if data-input 226 | (setf *data-input* (call-data-input data-input)) 227 | (setf *data-input* nil)))) 228 | 229 | -------------------------------------------------------------------------------- /transform.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :cl-meld) 3 | 4 | (defmacro transform-part-expression (part &optional (stop-here nil)) 5 | (alexandria:with-gensyms (x) 6 | `(with-symbol (,x ,part) 7 | (if (funcall test-fn ,x) 8 | (multiple-value-bind (new-val stop-p) (funcall transform-fn ,x) 9 | ,@(when stop-here 10 | `((declare (ignore stop-p)))) 11 | (when new-val (setf ,x new-val)) 12 | ,@(unless stop-here 13 | `((when (not (eq stop-p :stop)) 14 | (transform-expr test-fn transform-fn ,x))))) 15 | ,@(unless stop-here 16 | `((transform-expr test-fn transform-fn ,x))))))) 17 | 18 | (defun transform-expr (test-fn transform-fn expr) 19 | "Traverses the entire expression and changes it. 20 | For each sub-expression, test-fn is called. 21 | If the test returns T, we execute transform-fn for the sub-expression. 22 | The return value must be two-valued: 23 | 1st - The new value for this sub-expression (if nil no change is done) 24 | 2nd - The :stop symbol, which stops the iteration for deeper sub-expressions inside this sub-expression" 25 | (unless expr 26 | (return-from transform-expr nil)) 27 | (cond 28 | ;; we do nothing for these 29 | ((var-p expr)) 30 | ((bool-p expr)) 31 | ((int-p expr)) 32 | ((float-p expr)) 33 | ((host-id-p expr)) 34 | ((nil-p expr)) 35 | ((world-p expr)) 36 | ((cpus-p expr)) 37 | ((addr-p expr)) 38 | ((host-id-p expr)) 39 | ((thread-id-p expr)) 40 | ((host-p expr)) 41 | ((string-constant-p expr)) 42 | ((argument-p expr)) 43 | ((get-constant-p expr)) 44 | ;; the real deal 45 | ((constant-p expr) 46 | (transform-part-expression (constant-expr expr))) 47 | ((clause-p expr) 48 | (transform-expr test-fn transform-fn (clause-head expr)) 49 | (transform-expr test-fn transform-fn (clause-body expr))) 50 | ((subgoal-p expr) 51 | (loop-cons-car (arg (subgoal-args expr)) 52 | (transform-part-expression arg))) 53 | ((comprehension-p expr) 54 | (with-comprehension expr (:left left :right right) 55 | (transform-part-expression left) 56 | (transform-part-expression right))) 57 | ((agg-construct-p expr) 58 | (with-agg-construct expr (:body body :head head :head0 head0) 59 | (transform-part-expression body) 60 | (transform-part-expression head0) 61 | (transform-part-expression head))) 62 | ((constraint-p expr) (transform-part-expression (constraint-expr expr))) 63 | ((assignment-p expr) 64 | (transform-part-expression (assignment-var expr) t) 65 | (transform-part-expression (assignment-expr expr))) 66 | ((call-p expr) 67 | (loop-cons-car (arg (call-args expr)) 68 | (transform-part-expression arg))) 69 | ((callf-p expr) 70 | (loop-cons-car (arg (callf-args expr)) 71 | (transform-part-expression arg))) 72 | ((struct-p expr) 73 | (loop-cons-car (el (struct-list expr)) 74 | (transform-part-expression el))) 75 | ((struct-val-p expr) 76 | (transform-part-expression (struct-val-var expr))) 77 | ((cons-p expr) 78 | (transform-part-expression (cons-head expr)) 79 | (transform-part-expression (cons-tail expr))) 80 | ((head-p expr) (transform-part-expression (head-list expr))) 81 | ((tail-p expr) (transform-part-expression (tail-list expr))) 82 | ((let-p expr) 83 | (transform-part-expression (let-var expr)) 84 | (transform-part-expression (let-expr expr)) 85 | (transform-part-expression (let-body expr))) 86 | ((if-p expr) 87 | (transform-part-expression (if-cmp expr)) 88 | (transform-part-expression (if-e1 expr)) 89 | (transform-part-expression (if-e2 expr))) 90 | ((not-p expr) (transform-part-expression (not-expr expr))) 91 | ((test-nil-p expr) (transform-part-expression (test-nil-expr expr))) 92 | ((convert-float-p expr) (transform-part-expression (convert-float-expr expr))) 93 | ((op-p expr) 94 | (transform-part-expression (op-op1 expr)) 95 | (transform-part-expression (op-op2 expr))) 96 | ((exist-p expr) 97 | (transform-part-expression (exist-body expr))) 98 | ((conditional-p expr) 99 | (transform-part-expression (conditional-cmp expr)) 100 | (transform-part-expression (conditional-term1 expr)) 101 | (transform-part-expression (conditional-term2 expr))) 102 | ((list-of-lists-p expr) 103 | (loop-cons-car (e expr) 104 | (transform-part-expression e))) 105 | (t (error 'expr-invalid-error 106 | :text (tostring "transform-expr: Invalid expression: ~a" expr)))) 107 | expr) 108 | 109 | (defmacro do-map-expr (expr) 110 | `(map-expr test-fn map-fn ,expr :go-down-fn go-down-fn)) 111 | 112 | (defmacro map-atom-expr () 113 | `(if (funcall test-fn expr) 114 | (funcall map-fn expr) 115 | expr)) 116 | 117 | (defmacro with-mapped-expr (&body body) 118 | `(cond 119 | ((funcall test-fn expr) 120 | (funcall map-fn expr)) 121 | ((funcall go-down-fn expr) 122 | ,@body) 123 | (t expr))) 124 | 125 | (defun map-expr (test-fn map-fn expr &key (go-down-fn #'always-true)) 126 | "Traverses the expression and creates a new expression. 127 | This is the functional counterpart of transform-expr. 128 | Parameters: 129 | - test-fn: called to check if map-fn is to be called upon the expression. 130 | - map-fn: called after test-fn succeeds. transforms the expression into something. 131 | - go-down-fn: called to check if we should go down into sub-expressions. 132 | only called if test-fn returns nil. 133 | - expr: the expression to be mapped." 134 | (unless expr 135 | (return-from map-expr nil)) 136 | (cond 137 | ((var-p expr) (map-atom-expr)) 138 | ((int-p expr) (map-atom-expr)) 139 | ((float-p expr) (map-atom-expr)) 140 | ((host-id-p expr) (map-atom-expr)) 141 | ((nil-p expr) (map-atom-expr)) 142 | ((world-p expr) (map-atom-expr)) 143 | ((cpus-p expr) (map-atom-expr)) 144 | ((addr-p expr) (map-atom-expr)) 145 | ((get-constant-p expr) (map-atom-expr)) 146 | ((clause-p expr) 147 | (with-mapped-expr 148 | (make-clause (do-map-expr (clause-body expr)) 149 | (do-map-expr (clause-head expr)) 150 | (clause-options expr)))) 151 | ((subgoal-p expr) 152 | (with-mapped-expr 153 | (make-subgoal (subgoal-name expr) 154 | (mapcar #L(do-map-expr !1) (subgoal-args expr))))) 155 | ((constraint-p expr) 156 | (with-mapped-expr 157 | (make-constraint (do-map-expr (constraint-expr expr)) 158 | (constraint-priority expr)))) 159 | ((assignment-p expr) 160 | (with-mapped-expr 161 | (make-assignment (do-map-expr (assignment-var expr)) 162 | (do-map-expr (assignment-expr expr))))) 163 | ((let-p expr) 164 | (with-mapped-expr 165 | (make-let (do-map-expr (let-var expr)) 166 | (do-map-expr (let-expr expr)) 167 | (do-map-expr (let-body expr))))) 168 | ((call-p expr) 169 | (with-mapped-expr 170 | (make-call (call-name expr) 171 | (mapcar #L(do-map-expr !1) (call-args expr))))) 172 | ((cons-p expr) 173 | (with-mapped-expr 174 | (make-cons (do-map-expr (cons-head expr)) 175 | (do-map-expr (cons-tail expr))))) 176 | ((head-p expr) 177 | (with-mapped-expr 178 | (make-head (do-map-expr (head-list expr))))) 179 | ((tail-p expr) 180 | (with-mapped-expr 181 | (make-tail (do-map-expr (tail-list expr))))) 182 | ((not-p expr) 183 | (with-mapped-expr 184 | (make-not (do-map-expr (not-expr expr))))) 185 | ((test-nil-p expr) 186 | (with-mapped-expr 187 | (make-test-nil (do-map-expr (test-nil-expr expr))))) 188 | ((if-p expr) 189 | (with-mapped-expr 190 | (make-if (do-map-expr (if-cmp expr)) 191 | (do-map-expr (if-e1 expr)) 192 | (do-map-expr (if-e2 expr))))) 193 | ((convert-float-p expr) 194 | (with-mapped-expr 195 | (make-convert-float (do-map-expr (convert-float-expr expr))))) 196 | ((op-p expr) 197 | (with-mapped-expr 198 | (make-op (op-op expr) 199 | (do-map-expr (op-op1 expr)) 200 | (do-map-expr (op-op2 expr))))) 201 | ((list-of-lists-p expr) 202 | (loop for item in expr 203 | collect (do-map-expr item))) 204 | (t (error 'expr-invalid-error 205 | :text (tostring "map-expr: Invalid expression: ~a" expr))))) 206 | 207 | (defun transform-drop-subgoal-first-arg (clause) 208 | (assert (clause-p clause)) 209 | (transform-expr #'subgoal-p 210 | #'(lambda (sub) 211 | ; For some reason, cl-yacc may share subgoal structures 212 | (with-subgoal sub (:args args) 213 | (setf (subgoal-args sub) (rest args))) 214 | (values nil :stop)) 215 | clause)) 216 | 217 | (defun transform-variable-to-expression (clause old-var expr) 218 | (assert (clause-p clause)) 219 | (let (new-constraint) 220 | (flet ((transform (var) 221 | (declare (ignore var)) 222 | (values expr :stop))) 223 | (with-clause clause (:head head :body body) 224 | (transform-expr #L(var-eq-p !1 old-var) 225 | #'transform head) 226 | (transform-expr #L(var-eq-p !1 old-var) 227 | #'transform (get-constraints body)) 228 | (dolist (a (get-assignments body)) 229 | (transform-expr #L(var-eq-p !1 old-var) 230 | #'transform (assignment-expr a))) 231 | (when (subgoals-in-list-have-var-p body old-var) 232 | (push-end (make-constraint (make-equal old-var '= expr) :type-bool) (clause-body clause))))))) 233 | 234 | (defun transform-variable-to-host-id (clause old-var) 235 | (let (host-var) 236 | ;; try to find an assignment of the form A = @host 237 | ;; and use A as the host variable. 238 | (dolist (a (get-assignments (clause-body clause))) 239 | (with-assignment a (:var var :expr e) 240 | (when (host-p e) 241 | (setf host-var var)))) 242 | (transform-variable-to-expression clause old-var (if host-var host-var (make-host-id))))) 243 | 244 | (defun transform-variable-to-thread-id (clause old-var) 245 | (transform-variable-to-expression clause old-var (make-thread-id))) 246 | 247 | (defun map-one-variable-to-another (expr old-var new-var) 248 | (map-expr #'(lambda (x) (var-eq-p x old-var)) 249 | #'(lambda (var) (declare (ignore var)) new-var) 250 | expr 251 | :go-down-fn 252 | #'(lambda (x) 253 | (cond 254 | ((let-p x) 255 | (if (var-eq-p (let-var x) old-var) 256 | nil 257 | t)) 258 | (t t))) 259 | )) 260 | 261 | (defun optimize-expr (expr assigns constraints) 262 | (let ((const (expr-is-constant-p expr constraints assigns))) 263 | (if const 264 | (compute-constant-expr const) 265 | (cond 266 | ((bool-p expr) expr) 267 | ((var-p expr) expr) 268 | ((literal-p expr) expr) 269 | ((get-constant-p expr) expr) 270 | ((thread-id-p expr) expr) 271 | ((host-id-p expr) expr) 272 | ((argument-p expr) expr) 273 | ((world-p expr) expr) 274 | ((cpus-p expr) expr) 275 | ((host-p expr) expr) 276 | ((struct-val-p expr) expr) 277 | ((if-p expr) 278 | (let ((cmp (if-cmp expr)) 279 | (e1 (if-e1 expr)) 280 | (e2 (if-e2 expr))) 281 | (setf (if-cmp expr) (optimize-expr cmp assigns constraints) 282 | (if-e1 expr) (optimize-expr e1 assigns constraints) 283 | (if-e2 expr) (optimize-expr e2 assigns constraints)) 284 | (if (bool-p (if-cmp expr)) 285 | (if (bool-val (if-cmp expr)) 286 | (if-e1 expr) 287 | (if-e2 expr)) 288 | expr))) 289 | ((callf-p expr) 290 | (let ((new-args (mapcar #L(optimize-expr !1 assigns constraints) (callf-args expr)))) 291 | (setf (callf-args expr) new-args) 292 | expr)) 293 | ((call-p expr) 294 | (let ((new-args (mapcar #L(optimize-expr !1 assigns constraints) (call-args expr)))) 295 | (setf (call-args expr) new-args) 296 | expr)) 297 | ((let-p expr) 298 | (setf (let-expr expr) (optimize-expr (let-expr expr) assigns constraints) 299 | (let-body expr) (optimize-expr (let-body expr) assigns constraints)) 300 | expr) 301 | ((convert-float-p expr) 302 | (setf (convert-float-expr expr) (optimize-expr (convert-float-expr expr) assigns constraints)) 303 | expr) 304 | ((struct-p expr) 305 | (let ((new-ls (mapcar #L(optimize-expr !1 assigns constraints) (struct-list expr)))) 306 | (setf (struct-list expr) new-ls) 307 | expr)) 308 | ((cons-p expr) 309 | (setf (cons-tail expr) (optimize-expr (cons-tail expr) assigns constraints) 310 | (cons-head expr) (optimize-expr (cons-head expr) assigns constraints)) 311 | expr) 312 | ((head-p expr) 313 | (setf (head-list expr) (optimize-expr (head-list expr) assigns constraints)) 314 | expr) 315 | ((tail-p expr) 316 | (setf (tail-list expr) (optimize-expr (tail-list expr) assigns constraints)) 317 | expr) 318 | ((not-p expr) 319 | (setf (not-expr expr) (optimize-expr (not-expr expr) assigns constraints)) 320 | expr) 321 | ((test-nil-p expr) 322 | (setf (test-nil-expr expr) (optimize-expr (test-nil-expr expr) assigns constraints)) 323 | expr) 324 | ((op-p expr) 325 | (cond 326 | ((and (eq :equal (op-op expr)) (bool-p (op-op2 expr)) (bool-val (op-op2 expr))) 327 | (optimize-expr (op-op1 expr) assigns constraints)) 328 | ((and (eq :equal (op-op expr)) (bool-p (op-op1 expr)) (bool-val (op-op1 expr))) 329 | (optimize-expr (op-op2 expr) assigns constraints)) 330 | (t 331 | (let ((e1 (op-op1 expr)) 332 | (e2 (op-op2 expr))) 333 | (setf (op-op1 expr) (optimize-expr e1 assigns constraints)) 334 | (setf (op-op2 expr) (optimize-expr e2 assigns constraints)) 335 | expr)))) 336 | (t (error 'expr-invalid-error 337 | :text (tostring "optimize-expr: don't know how to optimize expression ~a" expr))))))) 338 | 339 | (defun replace-variable (clause old-var new-var) 340 | (assert (not (var-eq-p old-var new-var))) 341 | (setf (clause-body clause) (nsubst new-var old-var (clause-body clause) :test #'equal)) 342 | (do-subgoals (clause-head clause) (:subgoal sub) 343 | (nsubst new-var old-var sub :test #'equal)) 344 | (do-exists (clause-head clause) (:var-list vars :body body) 345 | (unless (find-if #L(var-eq-p !1 old-var) vars) 346 | (nsubst new-var old-var body :test #'equal))) 347 | (do-comprehensions (clause-head clause) (:left left :right right :variables vars) 348 | (unless (find-if #L(var-eq-p !1 old-var) vars) 349 | (nsubst new-var old-var left :test #'equal) 350 | (nsubst new-var old-var right :test #'equal))) 351 | (do-agg-constructs (clause-head clause) (:body body :head head :head0 head0 :vlist vars :spec-vars spec-vars) 352 | (unless (find-if #L(var-eq-p !1 old-var) (append vars spec-vars)) 353 | (nsubst new-var old-var body :test #'equal) 354 | (nsubst new-var old-var head0 :test #'equal) 355 | (nsubst new-var old-var head :test #'equal))) 356 | clause) 357 | -------------------------------------------------------------------------------- /types.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (defun type-list-p (x) (tagged-p x :type-list)) 4 | (defun make-list-type (ty) `(:type-list ,ty)) 5 | (defun type-list-element (x) (second x)) 6 | 7 | (defun type-array-p (x) (tagged-p x :type-array)) 8 | (defun make-array-type (ty) `(:type-array ,ty)) 9 | (defun type-array-element (x) (second x)) 10 | 11 | (defun type-set-p (x) (tagged-p x :type-set)) 12 | (defun make-set-type (ty) `(:type-set ,ty)) 13 | (defun type-set-element (x) (second x)) 14 | 15 | (defun type-struct-p (x) (tagged-p x :type-struct)) 16 | (defun make-struct-type (ls) `(:type-struct ,ls)) 17 | (defun type-struct-list (x) (second x)) 18 | 19 | (defun make-type-node (x) `(:type-node ,x)) 20 | (defun type-node-type (x) (second x)) 21 | (defun type-node-p (x) (tagged-p x :type-node)) 22 | 23 | (defparameter *number-types* '(:type-int :type-float)) 24 | (defparameter *list-number-types* (mapcar #'make-list-type *number-types*)) 25 | (defparameter *list-types* '((:type-list :all))) 26 | (defparameter *all-types* '(:all)) 27 | 28 | (defun is-all-type-p (x) 29 | (or (and (listp x) (one-elem-p x) (eq :all (first x))) 30 | (and x (eq (first x) :all)))) 31 | 32 | (defun has-all-type-p (x) (find-anywhere :all x)) 33 | 34 | (defmacro deftype-p (&rest types) 35 | `(on-top-level 36 | ,@(mapcar #'(lambda (x) `(defun ,(alexandria:format-symbol t "TYPE-~A-P" (symbol-name x)) (ty) 37 | (eq ,(alexandria:format-symbol "KEYWORD" "TYPE-~A" (symbol-name x)) ty))) 38 | types))) 39 | 40 | (deftype-p int addr bool string float thread) 41 | 42 | (defun valid-type-p (typ) 43 | (cond 44 | ((or (type-int-p typ) (type-addr-p typ) 45 | (type-bool-p typ) (type-string-p typ) 46 | (type-node-p typ) 47 | (type-float-p typ)) 48 | t) 49 | ((type-list-p typ) 50 | (valid-type-p (type-list-element typ))) 51 | ((type-struct-p typ) 52 | (every #'valid-type-p (type-struct-list typ))) 53 | ((type-array-p typ) 54 | (valid-type-p (type-array-element typ))) 55 | ((type-set-p typ) 56 | (valid-type-p (type-set-element typ))) 57 | (t 58 | (assert nil) 59 | nil))) 60 | 61 | (defun type-to-string (typ) 62 | (cond 63 | ((type-addr-p typ) "addr") 64 | ((type-int-p typ) "int") 65 | ((type-float-p typ) "float") 66 | ((type-bool-p typ) "bool") 67 | ((type-string-p typ) "string") 68 | ((type-thread-p typ) "thread") 69 | ((type-node-p typ) (tostring "node ~a" (type-node-type typ))) 70 | ((type-list-p typ) 71 | (tostring "list ~a" (type-to-string (type-list-element typ)))) 72 | ((type-array-p typ) 73 | (tostring "array ~a" (type-to-string (type-array-element typ)))) 74 | ((type-set-p typ) 75 | (tostring "set ~a" (type-to-string (type-set-element typ)))) 76 | ((type-struct-p typ) 77 | (let ((str "struct ")) 78 | (loop for ty in (type-struct-list typ) 79 | for i from 0 80 | do (setf str (concatenate 'string (concatenate 'string str (if (= i 0) "[" ", ")) 81 | (type-to-string ty)))) 82 | str)) 83 | (t 84 | (assert nil) 85 | ""))) 86 | 87 | (defun type-operands (op &optional forced-types) 88 | (cond 89 | ((eq-arith-p op) 90 | (if (is-all-type-p forced-types) 91 | *number-types* 92 | (if forced-types 93 | (intersection forced-types *number-types*) 94 | *number-types*))) 95 | ((eq-num-cmp-p op) 96 | (if (or (has-elem-p forced-types :type-bool) 97 | (is-all-type-p forced-types)) 98 | *number-types*)) 99 | ((eq-cmp-p op) 100 | (if (or forced-types 101 | (not (has-elem-p forced-types :type-bool))) 102 | *all-types*)) 103 | (t (warn "not valid operands") nil))) 104 | 105 | (defun type-op (op &optional forced-types) 106 | (cond 107 | ((eq-arith-p op) 108 | (if (is-all-type-p forced-types) 109 | *number-types* 110 | (if forced-types 111 | (intersection *number-types* forced-types) 112 | '*number-types*))) 113 | ((eq-cmp-p op) 114 | (if (is-all-type-p forced-types) 115 | '(:type-bool) 116 | (if forced-types 117 | (intersection '(:type-bool) forced-types) 118 | '(:type-bool)))))) 119 | 120 | (defun type-oper-op (op forced-types) 121 | (cond 122 | ((eq-arith-p op) 123 | (intersection *number-types* forced-types)) 124 | ((eq-cmp-p op) '(:type-bool)))) 125 | 126 | (defun expr-type (expr) 127 | (cond 128 | ((or (nil-p expr) (host-id-p expr) (thread-id-p expr) (cpus-p expr) (world-p expr)) (second expr)) 129 | ((or (var-p expr) (int-p expr) (bool-p expr) (float-p expr) (addr-p expr) (tail-p expr) 130 | (head-p expr) (not-p expr) (test-nil-p expr) 131 | (convert-float-p expr) 132 | (get-constant-p expr) 133 | (argument-p expr) 134 | (struct-p expr)) 135 | (third expr)) 136 | ((or (op-p expr) (struct-val-p expr) (call-p expr) (callf-p expr) (cons-p expr)) 137 | (fourth expr)) 138 | ((or (let-p expr) (if-p expr)) (fifth expr)) 139 | (t (assert nil) (error 'type-invalid-error :text (tostring "expr-type: cannot deduce type of expression ~a" expr))))) 140 | 141 | (defun typed-var-p (var) (and (= (length var) 3))) 142 | (defun single-typed-var-p (var) 143 | (when (typed-var-p var) 144 | (if (valid-type-p (third var)) 145 | t 146 | (and (one-elem-p (third var)) 147 | (valid-type-p (first (third var))))))) 148 | (defun typed-op-p (op) (= (length op) 4)) 149 | (defun typed-int-p (i) (= (length i) 3)) 150 | 151 | (defun same-types-p (types1 types2) 152 | (set-equal-p types1 types2)) 153 | 154 | (defun type-eq-p (ty1 ty2) (equal ty1 ty2)) 155 | (defun simple-type-eq-p (ty1 ty2) (or (eq ty1 ty2) 156 | (and (listp ty1) (listp ty2) (eq (first ty1) (first ty2))))) 157 | 158 | (defun recursive-type-p (typ) 159 | (or (type-struct-p typ) (type-list-p typ) 160 | (type-array-p typ) 161 | (type-set-p typ))) 162 | 163 | (defun reference-type-p (typ) 164 | (or (eq typ :all) (type-string-p typ) 165 | (type-node-p typ) 166 | (type-addr-p typ) (recursive-type-p typ))) 167 | 168 | (defparameter *program-types* nil) 169 | 170 | (defun add-type-to-typelist (types new) 171 | (assert new) 172 | (if (member new types :test #'equal) 173 | types 174 | (cond 175 | ((type-list-p new) 176 | (push-end new (add-type-to-typelist types (type-list-element new)))) 177 | ((type-struct-p new) 178 | (dolist (x (type-struct-list new)) 179 | (setf types (add-type-to-typelist types x))) 180 | (push-end new types)) 181 | ((type-array-p new) 182 | (push-end new (add-type-to-typelist types (type-array-element new)))) 183 | ((type-set-p new) 184 | (push-end new (add-type-to-typelist types (type-set-element new)))) 185 | (t (push-end new types))))) 186 | 187 | (defun lookup-type-id (typ) 188 | (let ((ret (position typ *program-types* :test #'equal))) 189 | (assert (integerp ret)) 190 | ret)) 191 | 192 | -------------------------------------------------------------------------------- /util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-meld) 2 | 3 | (defparameter *debug-msgs* t) 4 | 5 | (defmacro printdbg (str &rest args) 6 | `(if *debug-msgs* 7 | (format t ,(concatenate 'string str "~%") ,@args))) 8 | 9 | (defun create-tab (&optional (n 4)) 10 | (tostring "~{~a~}" (loop for i from 1 to n collect " "))) 11 | 12 | (defun create-bin-array (&optional (size 0)) (make-array size :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)) 13 | 14 | (defun str->sym (str) (values (intern str))) 15 | 16 | (defun tagged-p (list tag) 17 | (and (listp list) 18 | (eq (first list) tag))) 19 | (defun tagged-tag (list) (first list)) 20 | 21 | (defun one-elem-p (list) 22 | (if (listp list) 23 | (null (cdr list)) 24 | t)) 25 | 26 | (defun one-elem-this (list this) 27 | (and (one-elem-p list) 28 | (equal (car list) this))) 29 | 30 | (defun at-least-n-p (ls n) 31 | (if (zerop n) 32 | t 33 | (and (not (null ls)) 34 | (at-least-n-p (cdr ls) (1- n))))) 35 | 36 | (defun get-first-n (ls n &optional (app nil)) 37 | (if (or (zerop n) (null ls)) 38 | app 39 | (cons (car ls) 40 | (get-first-n (cdr ls) (1- n) app)))) 41 | 42 | (defun drop-first-n (ls n) 43 | (if (zerop n) 44 | ls 45 | (drop-first-n (cdr ls) (1- n)))) 46 | 47 | (defun try-one (ls) 48 | (if (one-elem-p ls) 49 | (first ls) 50 | ls)) 51 | 52 | (defun has-elem-p (list el) (ensure-bool (member el list))) 53 | (defun has-test-elem-p (list el test) (ensure-bool (member el list :test test))) 54 | (defun find-anywhere (item tree) 55 | "Does item occur anywhere in tree?" 56 | (if (atom tree) 57 | (if (eql item tree) tree) 58 | (or (find-anywhere item (first tree)) 59 | (find-anywhere item (rest tree))))) 60 | 61 | (defun create-hash-set (ls) 62 | (let ((hash (make-hash-table :test #'equal))) 63 | (dolist (a ls) 64 | (setf (gethash a hash) t)) 65 | hash)) 66 | 67 | (defun remove-hash-set (hash-set el) (remhash el hash-set)) 68 | (defun in-hash-set-p (hash-set el) (gethash el hash-set)) 69 | 70 | (defmacro do-hash-set ((el hash-set) &body body) 71 | `(loop for ,el being the hash-keys of ,hash-set 72 | do (progn ,@body))) 73 | 74 | (defun copy-hash-table (h1 &optional (copy-fn #'identity)) 75 | (let ((h2 (make-hash-table :test #'equal))) 76 | (maphash #'(lambda (key val) (setf (gethash key h2) (funcall copy-fn val))) 77 | h1) 78 | h2)) 79 | 80 | (defun hash-keys (hash-table) 81 | (loop for key being the hash-keys of hash-table collect key)) 82 | 83 | (defmacro any (predicates val) 84 | `(or ,@(mapcar (lambda (pred) `(,pred ,val)) predicates))) 85 | 86 | (defun dunion (l1 l2) (union l1 l2 :test #'equal)) 87 | 88 | (defmacro filter (&rest args) `(remove-if-not ,@args)) 89 | 90 | (defun mapfilter (trans f l) (mapcar trans (filter f l))) 91 | 92 | (defun filter-first (fun ls) 93 | "Find all the initial items x from ls where fun(x) is true." 94 | (cond 95 | ((null ls) nil) 96 | (t 97 | (when (funcall fun (first ls)) 98 | (cons (first ls) (filter-first fun (rest ls))))))) 99 | 100 | (defun enumerate (a b) 101 | (if (> a b) 102 | nil 103 | (cons a (enumerate (1+ a) b)))) 104 | 105 | (defun remove-tree (tree ls) (remove tree ls :test #'equal)) 106 | (defun remove-tree-first (tree ls) (remove tree ls :test #'equal :count 1)) 107 | 108 | (defmacro delete-one (from item) 109 | `(setf ,from (delete ,item ,from :test #'equal))) 110 | 111 | (defmacro delete-all (from ls) 112 | (alexandria:with-gensyms (el) 113 | `(progn 114 | (dolist (,el ,ls) 115 | (setf ,from (delete ,el ,from :test #'equal))) 116 | ,from))) 117 | 118 | (defun remove-all (from ls) (reduce #L(remove-tree !2 !1) ls :initial-value from)) 119 | 120 | (defmacro push-all (ls to) 121 | (alexandria:with-gensyms (el) 122 | `(dolist (,el ,ls) 123 | (push ,el ,to)))) 124 | 125 | (defmacro push-dunion (el to) `(setf ,to (dunion (list ,el) ,to))) 126 | 127 | (defmacro push-dunion-all (ls to) `(setf ,to (dunion ,ls ,to))) 128 | 129 | (defmacro set-tree-difference (t1 t2) `(set-difference ,t1 ,t2 :test #'equal)) 130 | (defmacro tree-intersection (t1 t2) `(intersection ,t1 ,t2 :test #'equal)) 131 | (defmacro tree-subsetp (t1 t2) `(subsetp ,t1 ,t2 :test #'equal)) 132 | 133 | (defun flatten (ls) 134 | (cond 135 | ((null ls) (list)) 136 | ((listp ls) 137 | (append (flatten (first ls)) (flatten (rest ls)))) 138 | (t (list ls)))) 139 | 140 | (defun set-equal-p (s1 s2) 141 | (and (subsetp s1 s2) 142 | (subsetp s2 s1))) 143 | 144 | (defun intersection-all (lists) 145 | "Returns the intersection of all sub-lists in 'lists'." 146 | (reduce #'intersection (rest lists) :initial-value (first lists))) 147 | 148 | (defun split-string (string &key (delimiterp #'delimiterp)) 149 | (loop :for beg = (position-if-not delimiterp string) 150 | :then (position-if-not delimiterp string :start (1+ end)) 151 | :for end = (and beg (position-if delimiterp string :start beg)) 152 | :when beg :collect (subseq string beg end) 153 | :while end)) 154 | 155 | (defun split (fn l) 156 | (let (y n) 157 | (loop for el in l 158 | do 159 | (if (funcall fn el) 160 | (push el y) 161 | (push el n))) 162 | (cons (reverse y) (reverse n)))) 163 | 164 | (defun split-mult-return (fn l) 165 | (destructuring-bind (filtered . removed) (split fn l) 166 | (values filtered removed))) 167 | 168 | (defmacro push-end (el ls) 169 | `(if (null ,ls) 170 | (setf ,ls (list ,el)) 171 | (nconc ,ls (list ,el)))) 172 | 173 | (defun addify (ls &optional (n 0)) 174 | (if (null ls) 175 | nil 176 | (cons n (addify (rest ls) (+ n (first ls)))))) 177 | 178 | (defun merge-strings (ls sep) 179 | (if (null ls) 180 | "" 181 | (reduce #L(if !1 (concatenate 'string !1 (list sep) !2) !2) ls))) 182 | 183 | (defun get-tagged-elem (ls key) 184 | (when ls 185 | (let ((found (find-if #L(eq (first !1) key) ls))) 186 | (when found 187 | (rest found))))) 188 | 189 | (defun shuffle-list (ls &optional (rnd *random-state*)) 190 | (let ((hash-tbl (make-hash-table :test #'eq))) 191 | (sort ls #'< :key #'(lambda (x) 192 | (multiple-value-bind (val found-p) (gethash x hash-tbl) 193 | (if found-p 194 | val 195 | (setf (gethash x hash-tbl) (random 1.0 rnd)))))))) 196 | 197 | (defun read-file (file) 198 | "Reads the entire file and returns a string." 199 | (with-open-file (str file 200 | :direction :input 201 | :if-does-not-exist :error) 202 | (reduce #L(concatenate 'string !1 !2 (list #\newline)) 203 | (loop for line = (read-line str nil nil) 204 | while line 205 | collect line) :initial-value ""))) 206 | 207 | (defun file-exists-p (file) 208 | (probe-file file)) 209 | 210 | (defun list-of-lists-p (ls) 211 | (and (listp ls) 212 | (every #'listp ls))) 213 | 214 | (defmacro loop-pairwise ((a b) ls &body body) 215 | (alexandria:with-gensyms (tail) 216 | `(loop for (,a . ,tail) on ,ls by #'cdr 217 | do (unless (null ,tail) 218 | (let ((,b (car ,tail))) 219 | ,@body))))) 220 | 221 | (defun all-equal-p (ls &key (test #'eq)) 222 | (loop-pairwise (a b) ls 223 | (unless (funcall test a b) 224 | (return-from all-equal-p nil))) 225 | t) 226 | 227 | (defun always-true (&rest rest) 228 | "Function that always returns true." 229 | (declare (ignore rest)) 230 | t) 231 | 232 | (defun ordered-p (ls &optional (fn #'<)) 233 | (all-equal-p ls :test fn)) 234 | 235 | (defun mappend (fn &rest lsts) 236 | "maps elements in list and finally appends all resulted lists." 237 | (apply #'append (apply #'mapcar fn lsts))) 238 | 239 | (defun replace-all (string part replacement &key (test #'char=)) 240 | "Returns a new string in which all the occurences of the part 241 | is replaced with replacement." 242 | (with-output-to-string (out) 243 | (loop with part-length = (length part) 244 | for old-pos = 0 then (+ pos part-length) 245 | for pos = (search part string 246 | :start2 old-pos 247 | :test test) 248 | do (write-string string out 249 | :start old-pos 250 | :end (or pos (length string))) 251 | when pos do (write-string replacement out) 252 | while pos))) 253 | 254 | (defun next-multiple-of-uint (x) (ceiling x 64)) 255 | -------------------------------------------------------------------------------- /yacc-comments.patch: -------------------------------------------------------------------------------- 1 | --- yacc.lisp 2009-01-03 16:40:09.000000000 -0500 2 | +++ ../cl-yacc/yacc.lisp 2011-06-20 21:56:09.000000000 -0400 3 | @@ -1064,9 +1064,11 @@ 4 | (or (cdr (assoc a (aref goto-array i))) 5 | (error "This cannot happen.")))) 6 | (let ((stack (list 0)) symbol value) 7 | - (flet ((next-symbol () 8 | + (labels ((next-symbol () 9 | (multiple-value-bind (s v) (funcall lexer) 10 | - (setq symbol (or s 'yacc-eof-symbol) value v)))) 11 | + (if (eq s :comment) 12 | + (next-symbol) 13 | + (setq symbol (or s 'yacc-eof-symbol) value v))))) 14 | (next-symbol) 15 | (loop 16 | (let* ((state (car stack)) 17 | --------------------------------------------------------------------------------