├── package.lisp ├── policy.lisp ├── policy-cond.asd ├── LICENSE.txt ├── policy-cond.lisp ├── README.txt └── expectations.lisp /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2014 Robert Smith 4 | 5 | (defpackage #:policy-cond 6 | (:use #:cl) 7 | (:export 8 | #:declaration-information 9 | #:policy-if 10 | #:policy-cond 11 | #:with-policy) 12 | (:export 13 | #:with-expectations)) 14 | 15 | (defpackage #:policy 16 | (:use #:cl) 17 | (:shadow #:if) 18 | (:export #:if)) 19 | -------------------------------------------------------------------------------- /policy.lisp: -------------------------------------------------------------------------------- 1 | ;;;; policy.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2014 Robert Smith 4 | 5 | (in-package #:policy) 6 | 7 | (defmacro if (form) 8 | "Intended to be used with read macros. FORM should be a policy 9 | expression as described in POLICY-COND:POLICY-COND. For example, 10 | 11 | #+#.(policy:if (> speed safety)) EXPRESSION" 12 | (labels ((replace-keys (form) 13 | (typecase form 14 | (keyword 15 | (or (find-symbol (symbol-name form) :cl) 16 | form)) 17 | (cons 18 | (mapcar #'replace-keys form)) 19 | (t 20 | form)))) 21 | `(policy-cond:policy-if ,(replace-keys form) '(:and) '(:or)))) 22 | -------------------------------------------------------------------------------- /policy-cond.asd: -------------------------------------------------------------------------------- 1 | ;;;; policy-cond.asd 2 | ;;;; 3 | ;;;; Copyright (c) 2014 Robert Smith 4 | 5 | (asdf:defsystem #:policy-cond 6 | :description "Tools to insert code based on compiler policy." 7 | :long-description "POLICY-COND provides tools to insert and execute code based on one's compiler's OPTIMIZE policy. It also contains a contract-like notion of 'expectations', which allow dynamic checking or inclusion of various things to happen depending on compiler policy." 8 | :author "Robert Smith " 9 | :maintainer "Robert Smith " 10 | :license "BSD 3-clause (See LICENSE)" 11 | :depends-on ((:feature :sbcl 12 | :sb-cltl2) ; An SBCL contrib enacapsulated via ASDF 13 | (:feature (:not (:or :sbcl :lispworks :cmucl :ccl :allegro)) 14 | :cl-environments)) 15 | :serial t 16 | :components ((:static-file "LICENSE.txt") 17 | (:file "package") 18 | (:file "policy-cond") 19 | (:file "expectations") 20 | (:file "policy"))) 21 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Robert Smith 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its 16 | contributors may be used to endorse or promote products derived from 17 | this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /policy-cond.lisp: -------------------------------------------------------------------------------- 1 | ;;;; policy-cond.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2014 Robert Smith 4 | 5 | (in-package #:policy-cond) 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (defun declaration-information (symbol &optional env) 9 | "Get the declaration information for the environment ENV." 10 | #+sbcl 11 | (sb-cltl2:declaration-information symbol env) 12 | 13 | #+lispworks 14 | (hcl:declaration-information symbol env) 15 | 16 | #+cmucl 17 | (ext:declaration-information symbol env) 18 | 19 | #+ccl 20 | (ccl:declaration-information symbol env) 21 | 22 | #+allegro 23 | (system:declaration-information symbol env) 24 | 25 | #-(or sbcl lispworks cmucl ccl allegro) 26 | (cl-environments.cltl2:declaration-information symbol env))) 27 | 28 | (defmacro policy (expr env) 29 | (let ((policy (declaration-information 'optimize env))) 30 | `(let ,policy 31 | (declare (ignorable ,@(mapcar #'car policy))) 32 | ,expr))) 33 | 34 | (defmacro policy-if (expr then else &environment env) 35 | "If the policy expression EXPR is true, then expand into THEN, 36 | otherwise into ELSE. The policy expression is as described in 37 | POLICY-COND." 38 | (if (eval `(policy ,expr ,env)) 39 | then 40 | else)) 41 | 42 | (defmacro policy-cond (&body cases) 43 | "Like COND, except each clause predicate is a policy expression. A 44 | policy expression is a boolean expression using optimize declaration 45 | qualities such as SPEED, SAFETY, DEBUG, COMPILATION-SPEED, etc. as if 46 | they're lexically bound to their actual value. 47 | 48 | The result of POLICY-COND will be the first clause whose policy 49 | expression is satisfied. This is computed at compile time based off 50 | the current compiler policy." 51 | (if (null cases) 52 | (error "No policy expression was satisfied.") 53 | `(policy-if ,(caar cases) 54 | (progn ,@(cdar cases)) 55 | (policy-cond ,@(cdr cases))))) 56 | 57 | (defmacro with-policy (policy &body body &environment env) 58 | "Execute the body BODY with the global optimize policy set to 59 | POLICY. Once BODY has finished executing, restore the compiler policy 60 | to its original state. 61 | 62 | For local declarations, use LOCALLY." 63 | (let ((saved-policy (declaration-information 'optimize env))) 64 | `(unwind-protect (progn 65 | (proclaim '(optimize ,@policy)) 66 | ,@body) 67 | (proclaim '(optimize ,@saved-policy))))) 68 | -------------------------------------------------------------------------------- /README.txt: -------------------------------------------------------------------------------- 1 | POLICY-COND 2 | =========== 3 | 4 | By Robert Smith 5 | 6 | License 7 | ------- 8 | 9 | This software is licensed under BSD 3-clause license. Please see LICENSE. 10 | 11 | 12 | Environment Introspection 13 | ------------------------- 14 | 15 | This library provides an interface to the CLtL2 environment 16 | functions. Currently, only DECLARATION-INFORMATION is supported. 17 | 18 | 19 | Temporarily Setting and Restoring Optimize Policy 20 | ------------------------------------------------- 21 | 22 | One can use WITH-POLICY to temporarily set the global optimize policy 23 | for e.g. loading systems. The original policy will be restored upon 24 | completion. 25 | 26 | WITH-POLICY should not be used with local declarations. In that case, 27 | one should use LOCALLY. 28 | 29 | 30 | Expansion Based on Policy 31 | ------------------------- 32 | 33 | POLICY-COND is a macro in order to select certain code paths based on 34 | the current optimize compiler policy. 35 | 36 | For example, given the following code: 37 | 38 | (declaim (optimize (speed 0) (safety 3))) 39 | 40 | (defun test-cond () 41 | (policy-cond 42 | ((> speed safety) (+ 1 1)) 43 | ((= speed safety) (+ 2 2)) 44 | ((< speed safety) (+ 3 3)))) 45 | 46 | The function TEST-COND will get compiled as if it were 47 | 48 | (defun test-cond () 49 | (+ 3 3)) 50 | 51 | The optimize qualities SPEED, SAFETY, SPACE, DEBUG, and 52 | COMPILATION-SPEED are guaranteed by an implementation. They can be 53 | used as if they are lexically bound. 54 | 55 | Currently, any expression for the policy expression can be used. In 56 | the future, this might change to a limited set of operators. 57 | 58 | Also included is POLICY-IF which behaves much like POLICY-COND, except 59 | is akin to CL:IF. 60 | 61 | Finally there is another package, POLICY, which exports IF, which is 62 | intended to be used with reader macros. For example, 63 | 64 | #+#.(policy:if (<= speed safety)) (safe-algorithm) 65 | 66 | Note that this does not work with local declarations. See 67 | 68 | http://clhs.lisp.se/Body/s_declar.htm#declare 69 | 70 | for details. 71 | 72 | 73 | Expectations 74 | ------------ 75 | 76 | An "expectation" is something the programmer expects to be true, but 77 | could be wrong if the consumer of the code makes a logical 78 | error. Expectations usually have different behavior in testing and 79 | production environments. When testing, it is permitted that code be 80 | slower due to sanity checking, and in production (after considerable 81 | testing), it may make sense to remove extra sanity checking and add 82 | speed improvements. 83 | 84 | POLICY-COND offers the notion of an expectation, which can change with 85 | policy. The macro POLICY-COND:WITH-EXPECTATIONS accomplishes this. It 86 | is best described with an example. 87 | 88 | (defun vector-item (vec n) 89 | (with-expectations (> speed safety) 90 | ((type unsigned-byte n) 91 | (type (vector single-float) vec) 92 | (assertion (< n (length vec)))) 93 | (aref vec n))) 94 | 95 | If the policy expression is not satisfied, then it will expand into 96 | 97 | (PROGN 98 | (CHECK-TYPE N UNSIGNED-BYTE) 99 | (CHECK-TYPE VEC (VECTOR SINGLE-FLOAT)) 100 | (ASSERT (< N (LENGTH VEC))) 101 | (AREF VEC N)) 102 | 103 | But if it is satisfied, it will expand into 104 | 105 | (LOCALLY (DECLARE (TYPE UNSIGNED-BYTE N) 106 | (TYPE (VECTOR SINGLE-FLOAT) VEC)) 107 | (AREF VEC N)) 108 | 109 | In other words, we can read 110 | 111 | (with-expectations POLICY (EXPECTATIONS...) BODY...) 112 | 113 | as 114 | 115 | "With the expectation that EXPECTATIONS are met when POLICY is 116 | true, execute BODY. Otherwise, ensure that they're true." 117 | 118 | See the documentation string for WITH-EXPECTATIONS to see the kinds of 119 | expectation clauses supported. 120 | 121 | 122 | See Also 123 | -------- 124 | 125 | For similar functionality for static function dispatch, see: 126 | 127 | https://bitbucket.org/tarballs_are_good/parameterized-function -------------------------------------------------------------------------------- /expectations.lisp: -------------------------------------------------------------------------------- 1 | ;;;; expectations.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2014 Robert Smith 4 | 5 | (in-package #:policy-cond) 6 | 7 | (defmacro with-expectations (policy (&rest expectations) &body body) 8 | "Execute BODY with expectations laid out by the clauses EXPECTATIONS when the policy expression POLICY holds true. When POLICY does not hold true, then EXPECTATIONS will be explicitly checked at runtime. 9 | 10 | EXPECTATIONS should be lists of one of the following forms. 11 | 12 | Type Expectation: (TYPE ...) 13 | 14 | Assert that the variables and expressions should 15 | have the type . If the POLICY is met, then declarations 16 | will be made for the variables only. 17 | 18 | Return Type Expectation: (RETURNS [*]) 19 | 20 | Assert that the result of a form obeys a certain type. Multiple 21 | types indicate multiple values are returned. If the POLICY is 22 | met, then the assertion will be elided at runtime. 23 | 24 | Assertion Expectation: (ASSERTION [(place*) [datum-form argument-form*]]) 25 | 26 | Assert that the assertion should be true. If the 27 | POLICY is met, then the assertion will be elided at runtime. 28 | 29 | Conditional Expectation: (OR-ELSE ) 30 | 31 | Check that the predicate is true, or else perform 32 | . If the POLICY is met, elide the check and 33 | action. This clause is principally used for having special 34 | conditions get raised. 35 | 36 | Inline Expectation: (INLINE [*]) 37 | 38 | Inline the functions designated by the symbols if POLICY 39 | is met. 40 | " 41 | (let ((preamble-forms nil) 42 | (local-declarations nil) 43 | (return-types :not-provided)) 44 | (labels ((keywordify (s) 45 | (intern (symbol-name s) :keyword)) 46 | 47 | (validate-expectation (e) 48 | (assert (listp e) (e) "Expected an expectation clause. Got ~S" e) 49 | (case (keywordify (car e)) 50 | ((:type) 51 | (assert (cdr e) () "Invalid type expectation: ~S" e) 52 | (assert (cddr e) () "Empty variable/expression list in type expectation: ~S" 53 | e)) 54 | 55 | ((:returns) nil) 56 | 57 | ((:inline) (assert (every #'symbolp (cdr e)) 58 | () 59 | "Invalid inline expectation received non-symbols: ~{~S~^, ~}" 60 | (remove-if #'symbolp (cdr e)))) 61 | 62 | ((:assertion) 63 | (assert (cdr e) 64 | () 65 | "Invalid assertion expectation: ~S" 66 | e)) 67 | 68 | ((:or-else) 69 | (assert (= 2 (length (cdr e))) 70 | () 71 | "Invalid or-else expectation. Expecting a predicate and a result, got: ~S" 72 | e)) 73 | 74 | (otherwise (warn "Ignoring unrecognized expectation: ~S" e)))) 75 | 76 | (parse-safe-expectation (e) 77 | (case (keywordify (car e)) 78 | ((:type) (let ((type (second e)) 79 | (vars (cddr e))) 80 | (dolist (var vars) 81 | (push `(check-type ,var ,type) preamble-forms)))) 82 | ((:returns) (setq return-types (cdr e))) 83 | ((:assertion) (push `(assert ,@(cdr e)) preamble-forms)) 84 | ((:or-else) (push `(unless ,(second e) 85 | ,(third e)) 86 | preamble-forms)))) 87 | 88 | (parse-speedy-expectation (e) 89 | (case (keywordify (car e)) 90 | ((:type) (let ((type (second e)) 91 | (vars (remove-if-not #'symbolp (cddr e)))) 92 | (push `(type ,type ,@vars) local-declarations))) 93 | ((:returns) nil) ; This will already have been parsed. 94 | ((:assertion) nil) 95 | ((:or-else) nil) 96 | ((:inline) (let ((syms (cdr e))) 97 | (when syms 98 | (push `(inline ,@(cdr e)) local-declarations))) )))) 99 | 100 | ;; Validate the expectations. 101 | (mapc #'validate-expectation expectations) 102 | (assert (> 2 (count :return-type expectations 103 | :key (lambda (ex) (keywordify (car ex))))) 104 | () 105 | "There are more than one return type expectations ~ 106 | provided when there should only be one.") 107 | 108 | ;; Parse the expectations. 109 | (mapc #'parse-safe-expectation expectations) 110 | (mapc #'parse-speedy-expectation expectations) 111 | ;; All of the forms are pushed into a list in order. Reverse 112 | ;; them so they're applied in the order they were presented. 113 | (setf preamble-forms (nreverse preamble-forms)) 114 | 115 | ;; Construct the policy form. 116 | `(policy-if 117 | ,policy 118 | ;; Speedy version (policy is satisfied). 119 | ,(if (null expectations) 120 | `(progn ,@body) 121 | (let ((contents 122 | (cond 123 | ((eql return-types :not-provided) body) 124 | ((= 1 (length return-types)) 125 | (list `(the ,@return-types (progn ,@body)))) 126 | (t (list `(the (values ,@return-types) (progn ,@body))))))) 127 | ;; XXX FIXME: MAKE THE OUTPUT BETTER 128 | (if local-declarations 129 | `(locally (declare ,@local-declarations) 130 | ,@contents) 131 | `(progn ,@contents)))) 132 | 133 | ;; Safe version (policy is not satisfied). 134 | ,(if (eql :not-provided return-types) 135 | `(progn 136 | ,@preamble-forms 137 | ,@body) 138 | (let ((result (gensym "RESULT-"))) 139 | (if (= 1 (length return-types)) 140 | ;; The simple case of one return type. 141 | `(progn 142 | ,@preamble-forms 143 | (let ((,result (progn ,@body))) 144 | (check-type ,result ,@return-types) 145 | ,result)) 146 | 147 | `(progn 148 | ,@preamble-forms 149 | (let ((,result (multiple-value-list (progn ,@body)))) 150 | (assert (= ,(length return-types) 151 | (length ,result)) 152 | () 153 | "Expected ~D values to get returned. Got ~D." 154 | ,(length return-types) 155 | (length ,result)) 156 | ,@(loop :for i :from 0 157 | :for type :in return-types 158 | :collect `(unless (typep (nth ,i ,result) ',type) 159 | (error 'simple-type-error 160 | :format-control ,(format nil "The ~:R value returned, ~~S, is not of type ~S." 161 | (1+ i) 162 | type) 163 | :format-arguments (list (nth ,i ,result)) 164 | :datum (nth ,i ,result) 165 | :expected-type ',type))) 166 | #+#:ignore 167 | (loop :for ,i :from 1 168 | :for ,value :in ,result 169 | :for ,type :in ',return-types 170 | :do (unless (typep ,value ,type) 171 | (error 'simple-type-error 172 | :format-control "The ~:R value returned, ~S, is not of type ~S." 173 | :format-arguments (list ,i ,value ,type) 174 | :datum ,value 175 | :expected-type ,type))) 176 | (values-list ,result)))))))))) 177 | --------------------------------------------------------------------------------