mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-25 05:51:55 -08:00
cmp: refactor cmppolicy (part 2)
- define-policy has more strict syntax checking - define-policy puts clauses in parenthesis - compute-policy is rewritten for readibility - augment-policy is rewritten for readibility - define-policy and define-policy-alias are separate macros
This commit is contained in:
Daniel Kochmański
parent
6a4d094f0f
commit
e9668d798c
2 changed files with 146 additions and 124 deletions
|
|
@ -66,74 +66,100 @@
|
|||
;; ERROR CHECKING POLICY
|
||||
;;
|
||||
|
||||
(define-policy ext:assume-no-errors :off safety 1)
|
||||
(define-policy ext:assume-no-errors
|
||||
"All bets are off."
|
||||
(:off safety 1))
|
||||
|
||||
(define-policy ext:assume-right-type :alias ext:assume-no-errors)
|
||||
(define-policy-alias ext:assume-right-type
|
||||
"Don't insert optional runtime type checks for known types."
|
||||
(:alias ext:assume-no-errors))
|
||||
|
||||
(define-policy ext:type-assertions :anti-alias ext:assume-no-errors
|
||||
"Generate type assertions when inlining accessors and other functions.")
|
||||
(define-policy-alias ext:type-assertions
|
||||
"Generate type assertions when inlining accessors and other functions."
|
||||
(:anti-alias ext:assume-no-errors))
|
||||
|
||||
(define-policy ext:check-stack-overflow :on safety 2
|
||||
"Add a stack check to every function")
|
||||
(define-policy ext:check-stack-overflow
|
||||
"Add a stack check to every function"
|
||||
(:on safety 2))
|
||||
|
||||
(define-policy ext:check-arguments-type :on safety 1
|
||||
"Generate CHECK-TYPE forms for function arguments with type declarations")
|
||||
(define-policy ext:check-arguments-type
|
||||
"Generate CHECK-TYPE forms for function arguments with type declarations."
|
||||
(:on safety 1))
|
||||
|
||||
(define-policy ext:array-bounds-check :on safety 1
|
||||
"Check out of bounds access to arrays")
|
||||
(define-policy ext:array-bounds-check
|
||||
"Check out of bounds access to arrays."
|
||||
(:on safety 1))
|
||||
|
||||
(define-policy ext:global-var-checking :on safety 3
|
||||
"Read the value of a global variable even if it is discarded, ensuring it is bound")
|
||||
(define-policy ext:global-var-checking
|
||||
"Read the value of a global variable even if it is discarded, ensuring it is bound."
|
||||
(:on safety 3))
|
||||
|
||||
(define-policy ext:global-function-checking :on safety 3
|
||||
"Read the binding of a global function even if it is discarded")
|
||||
(define-policy ext:global-function-checking
|
||||
"Read the binding of a global function even if it is discarded."
|
||||
(:on safety 3))
|
||||
|
||||
(define-policy ext:check-nargs :on safety 1 :only-on ext:check-arguments-type 1
|
||||
"Check that the number of arguments a function receives is within bounds")
|
||||
(define-policy ext:check-nargs
|
||||
"Check that the number of arguments a function receives is within bounds."
|
||||
(:on safety 1)
|
||||
(:only-on ext:check-arguments-type))
|
||||
|
||||
(define-policy ext:the-is-checked :on safety 1
|
||||
"THE is equivalent to EXT:CHECKED-VALUE. Otherwise THE is equivalent to EXT:TRULY-THE.")
|
||||
(define-policy ext:the-is-checked
|
||||
"THE is equivalent to EXT:CHECKED-VALUE. Otherwise THE is equivalent to EXT:TRULY-THE."
|
||||
(:on safety 1))
|
||||
|
||||
;;
|
||||
;; INLINING POLICY
|
||||
;;
|
||||
|
||||
(define-policy ext:assume-types-dont-change :off safety 1
|
||||
"Assume that type and class definitions will not change")
|
||||
(define-policy ext:assume-types-dont-change
|
||||
"Assume that type and class definitions will not change."
|
||||
(:off safety 1))
|
||||
|
||||
(define-policy ext:inline-slot-access :on speed 1 :off debug 2 :off safety 2
|
||||
"Inline access to structures and sealed classes")
|
||||
(define-policy ext:inline-slot-access
|
||||
"Inline access to structures and sealed classes."
|
||||
(:on speed 1)
|
||||
(:off debug 2)
|
||||
(:off safety 2))
|
||||
|
||||
(define-policy ext:inline-accessors :off debug 2 :off space 2
|
||||
"Inline access to object slots, including conses and arrays")
|
||||
(define-policy ext:inline-accessors
|
||||
"Inline access to object slots, including conses and arrays."
|
||||
(:off debug 2)
|
||||
(:off space 2))
|
||||
|
||||
(define-policy ext:inline-bit-operations :off space 2
|
||||
"Inline LDB and similar functions")
|
||||
(define-policy ext:inline-bit-operations
|
||||
"Inline LDB and similar functions."
|
||||
(:off space 2))
|
||||
|
||||
(define-policy ext:open-code-aref/aset :alias ext:inline-accessors
|
||||
"Inline access to arrays")
|
||||
(define-policy-alias ext:open-code-aref/aset
|
||||
"Inline access to arrays."
|
||||
(:alias ext:inline-accessors))
|
||||
|
||||
(define-policy ext:evaluate-forms :off debug 1
|
||||
"Pre-evaluate a function that takes constant arguments")
|
||||
(define-policy ext:evaluate-forms
|
||||
"Pre-evaluate a function that takes constant arguments."
|
||||
(:off debug 1))
|
||||
|
||||
(define-policy ext:use-direct-C-call :off debug 2
|
||||
"Emit direct calls to a function whose C name is known")
|
||||
(define-policy ext:use-direct-C-call
|
||||
"Emit direct calls to a function whose C name is known."
|
||||
(:off debug 2))
|
||||
|
||||
(define-policy ext:inline-type-checks :off space 2
|
||||
"Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP,
|
||||
INTGERP, STRINGP.")
|
||||
(define-policy ext:inline-type-checks
|
||||
"Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP, INTGERP, STRINGP."
|
||||
(:off space 2))
|
||||
|
||||
(define-policy ext:inline-sequence-functions :off space 2
|
||||
"Inline functions such as MAP, MEMBER, FIND, etc")
|
||||
(define-policy ext:inline-sequence-functions
|
||||
"Inline functions such as MAP, MEMBER, FIND, etc."
|
||||
(:off space 2))
|
||||
|
||||
;;
|
||||
;; DEBUG POLICY
|
||||
;;
|
||||
|
||||
(define-policy ext:debug-variable-bindings :on debug 3
|
||||
:requires (policy-debug-ihs-frame env)
|
||||
(define-policy ext:debug-variable-bindings
|
||||
"Create a debug vector with the bindings of each LET/LET*/LAMBDA form."
|
||||
;; We can only create variable bindings when the function has an IHS frame!!!
|
||||
"Create a debug vector with the bindings of each LET/LET*/LAMBDA form?")
|
||||
(:requires (policy-debug-ihs-frame env))
|
||||
(:on debug 3))
|
||||
|
||||
(define-policy ext:debug-ihs-frame :on debug 3
|
||||
"Let the functions appear in backtraces")
|
||||
(define-policy ext:debug-ihs-frame
|
||||
"Let the functions appear in backtraces."
|
||||
(:on debug 3))
|
||||
|
|
|
|||
|
|
@ -14,13 +14,15 @@
|
|||
|
||||
(in-package "COMPILER")
|
||||
|
||||
|
||||
(defconstant *standard-optimization-quality-names*
|
||||
'(debug safety speed space compilation-speed))
|
||||
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defvar *last-optimization-bit* 20)
|
||||
(defvar *optimization-quality-switches*
|
||||
(loop with hash = (make-hash-table :size 64 :test #'eq)
|
||||
for name in '(debug safety speed space compilation-speed)
|
||||
for name in *standard-optimization-quality-names*
|
||||
for i from 0 by 4
|
||||
for list = (loop with mask = (ash #b1111 i)
|
||||
for level from 0 to 3
|
||||
|
|
@ -28,12 +30,17 @@
|
|||
collect (cons bits (logxor bits mask)))
|
||||
do (setf (gethash name hash) list)
|
||||
finally (return hash)))
|
||||
(defvar *last-optimization-bit* 20)
|
||||
(defvar *optimization-bits* (make-hash-table)))
|
||||
;; For the standard qualities we encode the lowest bit position.
|
||||
(defvar *optimization-bits*
|
||||
(loop with hash = (make-hash-table :size 64 :test #'eq)
|
||||
for name in *standard-optimization-quality-names*
|
||||
for i from 0 by 4
|
||||
do (setf (gethash name hash) i)
|
||||
finally (return hash))))
|
||||
|
||||
(eval-when (:load-toplevel :execute)
|
||||
(defvar *optimization-quality-switches* #.*optimization-quality-switches*)
|
||||
(defvar *last-optimization-bit* #.*last-optimization-bit*)
|
||||
(defvar *optimization-quality-switches* #.*optimization-quality-switches*)
|
||||
(defvar *optimization-bits* #.*optimization-bits*))
|
||||
|
||||
(defun take-optimization-bit (name)
|
||||
|
|
@ -44,103 +51,92 @@
|
|||
(defun optimization-quality-switches (type index)
|
||||
(nth index (gethash type *optimization-quality-switches*)))
|
||||
|
||||
(defun compute-policy (arguments old-bits)
|
||||
(let* ((bits old-bits)
|
||||
(on 0)
|
||||
(off 0))
|
||||
(defun compute-policy (arguments old-bits &aux (on 0) (off 0))
|
||||
(flet ((get-flags (x)
|
||||
(if (atom x)
|
||||
(optimization-quality-switches x 3)
|
||||
(destructuring-bind (name value) x
|
||||
(when (typep value '(integer 0 3))
|
||||
(optimization-quality-switches name value))))))
|
||||
(dolist (x arguments)
|
||||
(let (flags name value)
|
||||
(cond ((symbolp x)
|
||||
(setq name x
|
||||
value 3
|
||||
flags (optimization-quality-switches name value)))
|
||||
((or (not (consp x))
|
||||
(not (consp (cdr x)))
|
||||
(not (numberp (second x)))
|
||||
(not (<= 0 (second x) 3))))
|
||||
(t
|
||||
(setf name (first x)
|
||||
value (second x)
|
||||
flags (optimization-quality-switches name value))))
|
||||
(if (null flags)
|
||||
(cmpwarn "Illegal or unknown OPTIMIZE proclamation ~s." x)
|
||||
(setf on (logior on (car flags))
|
||||
off (logior off (cdr flags))))))
|
||||
;;(format t "~%*~64b" bits)
|
||||
;;(format t "~% ~64b" on)
|
||||
;;(format t "~% ~64b" off)
|
||||
(logandc2 (logior bits on) off)))
|
||||
(ext:if-let ((flags (get-flags x)))
|
||||
(setf on (logior on (car flags))
|
||||
off (logior off (cdr flags)))
|
||||
(cmpwarn "Illegal or unknown OPTIMIZE proclamation ~s." x))))
|
||||
(logandc2 (logior old-bits on) off))
|
||||
|
||||
;;; for example debug 2 :on #x10
|
||||
(defun augment-policy (quality level on-off flag)
|
||||
(loop for i from 0 to 3
|
||||
for bits = (optimization-quality-switches quality i)
|
||||
do (if (< i level)
|
||||
(case on-off
|
||||
(:on (rplacd bits (logior (cdr bits) flag)))
|
||||
(:off (rplaca bits (logior (car bits) flag))))
|
||||
(case on-off
|
||||
((:only-on :on) (rplaca bits (logior (car bits) flag)))
|
||||
((:only-off :off) (rplacd bits (logior (cdr bits) flag)))))))
|
||||
(flet ((flip (on-off switches flag)
|
||||
(ecase on-off
|
||||
(:on (rplaca switches (logior (car switches) flag)))
|
||||
(:off (rplacd switches (logior (cdr switches) flag))))))
|
||||
(loop for i from 0 to 3
|
||||
for bits = (optimization-quality-switches quality i)
|
||||
do (if (< i level)
|
||||
(ecase on-off
|
||||
(:on (flip :off bits flag))
|
||||
(:off (flip :on bits flag))
|
||||
(:only-on nil)
|
||||
(:only-off nil))
|
||||
(ecase on-off
|
||||
(:on (flip :on bits flag))
|
||||
(:off (flip :off bits flag))
|
||||
(:only-on (flip :on bits flag))
|
||||
(:only-off (flip :off bits flag)))))))
|
||||
|
||||
(defun policy-function-name (base)
|
||||
(intern (concatenate 'string "POLICY-" (symbol-name base))
|
||||
(find-package "C")))
|
||||
|
||||
(defmacro define-policy (&whole whole name &rest conditions)
|
||||
(let* ((test (ash 1 (take-optimization-bit name)))
|
||||
(function-name (policy-function-name name))
|
||||
(doc (find-if #'stringp conditions))
|
||||
(emit-function t))
|
||||
;; If it is an alias, just copy the bits
|
||||
;; Register as an optimization quality with its own flags
|
||||
(let ((doc (and (stringp (car conditions)) (pop conditions)))
|
||||
(test (ash 1 (take-optimization-bit name)))
|
||||
(function-name (policy-function-name name)))
|
||||
;; Register as an optimization quality with its own flags.
|
||||
(let* ((circular-list (list (cons test 0)))
|
||||
(flags-list (list* (cons 0 test) circular-list)))
|
||||
(rplacd circular-list circular-list)
|
||||
(setf (gethash name *optimization-quality-switches*) flags-list))
|
||||
;; Scan the definition and correct the flags
|
||||
;; Scan the definition and propagate flags of dependent policies.
|
||||
(loop with extra = '()
|
||||
with conditions = (remove doc conditions)
|
||||
for case = (pop conditions)
|
||||
while case
|
||||
do (case case
|
||||
(:no-function
|
||||
(setf emit-function nil))
|
||||
(:alias
|
||||
(let* ((alias (first conditions)))
|
||||
(setf (gethash name *optimization-quality-switches*)
|
||||
(gethash alias *optimization-quality-switches*))
|
||||
(return `(defun ,function-name (&optional (env *cmp-env*))
|
||||
,@(and doc (list doc))
|
||||
(,(policy-function-name alias) env)))))
|
||||
(:anti-alias
|
||||
(let* ((alias (first conditions))
|
||||
(bits (gethash alias *optimization-quality-switches*)))
|
||||
|
||||
(setf bits (list (second bits)
|
||||
(first bits)))
|
||||
(rplacd (cdr bits) (cdr bits))
|
||||
(setf (gethash name *optimization-quality-switches*) bits)
|
||||
(return `(defun ,function-name (&optional (env *cmp-env*))
|
||||
,@(and doc (list doc))
|
||||
(not (,(policy-function-name alias) env))))))
|
||||
((:only-on :on)
|
||||
(augment-policy (pop conditions) (pop conditions) case test))
|
||||
((:only-off :off)
|
||||
(augment-policy (pop conditions) (pop conditions) case test))
|
||||
for case in conditions
|
||||
do (case (car case)
|
||||
((:on :off)
|
||||
(destructuring-bind (op quality level) case
|
||||
(augment-policy quality level op test)))
|
||||
((:only-on :only-off)
|
||||
(destructuring-bind (op quality) case
|
||||
(augment-policy quality 1 op test)))
|
||||
(:requires
|
||||
(push (pop conditions) extra))
|
||||
(destructuring-bind (op form) case
|
||||
(declare (ignore op))
|
||||
(push form extra)))
|
||||
(otherwise
|
||||
(error "Syntax error in macro~% ~A"
|
||||
`(define-policy ,@whole))))
|
||||
(error "Syntax error in macro~% ~A" `(define-policy ,@whole))))
|
||||
finally
|
||||
(return
|
||||
(and emit-function
|
||||
`(defun ,function-name (&optional (env *cmp-env*))
|
||||
,@(and doc (list doc))
|
||||
(let ((bits (cmp-env-policy env)))
|
||||
(and (logtest bits ,test)
|
||||
,@extra))))))))
|
||||
`(defun ,function-name (&optional (env *cmp-env*))
|
||||
,@(and doc (list doc))
|
||||
(let ((bits (cmp-env-policy env)))
|
||||
(and (logtest bits ,test)
|
||||
,@extra)))))))
|
||||
|
||||
(defmacro define-policy-alias (name doc (op alias))
|
||||
(let ((bits (gethash alias *optimization-quality-switches*)))
|
||||
(ecase op
|
||||
(:alias
|
||||
(setf (gethash name *optimization-quality-switches*) bits)
|
||||
`(defun ,(policy-function-name name) (&optional (env *cmp-env*))
|
||||
,doc
|
||||
(,(policy-function-name alias) env)))
|
||||
(:anti-alias
|
||||
(rotatef (first bits) (second bits))
|
||||
(rplacd (cdr bits) (cdr bits))
|
||||
(setf (gethash name *optimization-quality-switches*) bits)
|
||||
`(defun ,(policy-function-name name) (&optional (env *cmp-env*))
|
||||
,doc
|
||||
(not (,(policy-function-name alias) env)))))))
|
||||
|
||||
(macrolet ((define-function (fun-name offset)
|
||||
`(defun ,fun-name (policy)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue