diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index 377c8d419..45add7041 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -21,11 +21,7 @@ "Provide a root environment for toplevel forms storing all declarations that are susceptible to be changed by PROCLAIM." (let* ((env (cmp-env-copy env))) - (destructuring-bind (debug safety space speed) - (cmp-env-all-optimizations env) - (add-one-declaration env `(optimize - (speed ,speed) (space ,space) - (debug ,debug) (safety ,safety)))))) + (add-default-optimizations env))) (defun cmp-env-copy (&optional (env *cmp-env*)) (cons (car env) (cdr env))) diff --git a/src/cmp/cmpenv-declare.lsp b/src/cmp/cmpenv-declare.lsp index 5a47f3b8f..fcc5af082 100644 --- a/src/cmp/cmpenv-declare.lsp +++ b/src/cmp/cmpenv-declare.lsp @@ -109,54 +109,12 @@ and a possible documentation string (only accepted when DOC-P is true)." finally (return (values body specials types ignored (nreverse others) doc all-declarations))))) -(defun default-optimization (optimization) - (ecase optimization - (speed *speed*) - (safety *safety*) - (space *space*) - (debug *debug*))) - -(defun search-optimization-quality (declarations what) - (dolist (i (reverse declarations) - (default-optimization what)) - (when (and (consp i) (eq (first i) 'policy-debug-ihs-frame) - (eq what 'debug)) - (return 2)) - (when (and (consp i) (eq (first i) 'optimize)) - (dolist (j (rest i)) - (cond ((consp j) - (when (eq (first j) what) - (return-from search-optimization-quality (second j)))) - ((eq j what) - (return-from search-optimization-quality 3))))))) - -(defun compute-optimizations (arguments env) - (let ((optimizations (copy-list (cmp-env-all-optimizations env)))) - (dolist (x arguments) - (when (symbolp x) - (setq x (list x 3))) - (if (or (not (consp x)) - (not (consp (cdr x))) - (not (numberp (second x))) - (not (<= 0 (second x) 3))) - (cmpwarn "Illegal OPTIMIZE proclamation ~s" x) - (let ((value (second x))) - (case (car x) - (DEBUG (setf (first optimizations) value)) - (SAFETY (setf (second optimizations) value)) - (SPACE (setf (third optimizations) value)) - (SPEED (setf (fourth optimizations) value)) - (COMPILATION-SPEED) - (t (cmpwarn "Unknown OPTIMIZE quality ~s" (car x))))))) - optimizations)) - (defun add-one-declaration (env decl) "Add to the environment one declarations which is not type, ignorable or special variable declarations, as these have been extracted before." (case (car decl) (OPTIMIZE - (let ((optimizations (compute-optimizations (rest decl) env))) - (cmp-env-add-declaration 'optimize optimizations env))) + (cmp-env-add-optimizations (rest decl) env)) (POLICY-DEBUG-IHS-FRAME (let ((flag (or (rest decl) '(t)))) (if *current-function* diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index e8851d250..3b44b8608 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -89,7 +89,6 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (si::function-block-name name))) (children (fun-child-funs fun)) (global (and (assoc 'SI::C-GLOBAL decl) 'T)) - (debug (search-optimization-quality decl 'debug)) (no-entry (assoc 'SI::C-LOCAL decl)) cfun exported minarg maxarg) (when (and no-entry (policy-debug-ihs-frame)) diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp index 6ceff49e0..9d05d5800 100644 --- a/src/cmp/cmppolicy.lsp +++ b/src/cmp/cmppolicy.lsp @@ -14,52 +14,159 @@ (in-package #-new-cmp "COMPILER" #+new-cmp "C-ENV") -(defun cmp-env-all-optimizations (&optional (env *cmp-env*)) - (or (cmp-env-search-declaration 'optimize) - (list *debug* *safety* *space* *speed*))) - -(defun cmp-env-optimization (property &optional (env *cmp-env*)) - (let ((x (cmp-env-all-optimizations env))) - (case property - (debug (first x)) - (safety (second x)) - (space (third x)) - (speed (fourth x))))) +(eval-when (:compile-toplevel :execute) + (defconstant +optimization-quality-orders+ '(debug safety speed space))) (eval-when (:compile-toplevel :execute) - (defparameter +last-optimization-bit+ 0) + (defparameter *optimization-quality-switches* + #.(loop with hash = (make-hash-table :size 64 :test #'eq) + for name in +optimization-quality-orders+ + for i from 0 by 4 + for list = (loop with mask = (ash #b1111 i) + for level from 0 to 3 + for bits = (ash 1 (+ level i)) + collect (cons bits (logxor bits mask))) + do (setf (gethash name hash) list) + finally (return hash)))) + +(eval-when (:load-toplevel) + (defparameter *optimization-quality-switches* #.*optimization-quality-switches*)) + +#.`(eval-when (:compile-toplevel :execute :load-toplevel) + ,@(loop for name in +optimization-quality-orders+ + for i from 0 by 4 + for fun-name = (intern (concatenate 'string + "POLICY-TO-" (symbol-name name) "-LEVEL")) + collect `(defun ,fun-name (policy) + (loop for level from 0 to 3 + when (logbitp (+ level ,i) policy) + return level)))) + +(defun optimization-quality-switches (type index) + (nth index (gethash type *optimization-quality-switches*))) + +(defun compute-policy (arguments old-bits) + (let* ((bits old-bits)) + (dolist (x arguments) + (let (flags name value) + (cond ((symbolp x) + (setq flags (optimization-quality-switches x 3) + value 3 + name x)) + ((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 (second x))))) + (if (null flags) + (cmpwarn "Illegal or unknown OPTIMIZE proclamation ~s" x) + (setf bits (logandc2 (logior bits (car flags)) (cdr flags)))))) + bits)) + +(defun default-policy () + (compute-policy `((space ,*space*) + (safety ,*safety*) + (debug ,*debug*) + (speed ,*speed*)) + 0)) + +(defun cmp-env-policy (env) + (or (first (cmp-env-search-declaration 'optimization env)) + (default-policy))) + +(defun cmp-env-add-optimizations (decl &optional (env *cmp-env*)) + (let* ((old (cmp-env-policy env)) + (new (compute-policy decl old))) + (cmp-env-add-declaration 'optimization (list new) env))) + +(defun add-default-optimizations (env) + (if (cmp-env-search-declaration 'optimization) + env + (cmp-env-add-declaration 'optimization (list (default-policy)) env))) + +(defun cmp-env-all-optimizations (&optional (env *cmp-env*)) + (let ((o (cmp-env-policy env))) + (list (policy-to-debug-level o) + (policy-to-safety-level o) + (policy-to-space-level o) + (policy-to-speed-level o)))) + +(defun cmp-env-optimization (property &optional (env *cmp-env*)) + (let ((o (cmp-env-policy env))) + (case property + (debug (policy-to-debug-level o)) + (safety (policy-to-safety-level o)) + (space (policy-to-space-level o)) + (speed (policy-to-speed-level o))))) + +(eval-when (:compile-toplevel :execute) + (defparameter +last-optimization-bit+ 17) + (defun policy-bits (quality level) + (loop for i from level to 3 + sum (car (optimization-quality-switches quality i)))) (defmacro define-policy (&whole whole name &rest conditions) (let* ((test (ash 1 +last-optimization-bit+)) - (constant-name - (intern (concatenate 'string "+POLICY-" (symbol-name name) "+") - (find-package "C"))) + (declaration-name + (intern (concatenate 'string "POLICY-" (symbol-name name)))) (function-name (intern (concatenate 'string "POLICY-" (symbol-name name)) (find-package "C"))) (doc (find-if #'stringp conditions))) - (incf +last-optimization-bit+) - (loop with conditions = (remove doc conditions) + ;; 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) + (let ((*print-circle* t)) + (print (list* declaration-name flags-list))) + (incf +last-optimization-bit+) + (setf (gethash declaration-name *optimization-quality-switches*) + flags-list)) + ;; Scan the definition and correct the flags + (loop with extra = '() + with slow = '() + with bits-on = test + with bits-off = 0 + with conditions = (remove doc conditions) for case = (pop conditions) while case - collect + do (case case (:on - `(>= (cmp-env-optimization ',(pop conditions)) ,(pop conditions))) + (push `(>= (cmp-env-optimization ',(first conditions) env) + ,(second conditions)) + slow) + (setf bits-on (logior (policy-bits (pop conditions) + (pop conditions)) + bits-on))) (:off - `(< (cmp-env-optimization ',(pop conditions)) ,(pop conditions))) + (push `(< (cmp-env-optimization ',(first conditions) env) + ,(second conditions)) + slow) + (setf bits-off (logior (policy-bits (pop conditions) + (pop conditions)) + bits-off))) (:requires - (pop conditions)) + (push (pop conditions) extra)) (otherwise (error "Syntax error in macro~% ~A" `(define-policy ,@whole)))) - into expressions finally - (return - `(progn - (defparameter ,constant-name ,test ,@(and doc (list doc))) - (defun ,function-name (&optional (env *cmp-env*)) + (progn + (when (zerop (logandc2 bits-on test)) + (setf bits-on (logior (policy-bits 'speed 0) bits-on))) + (return + `(defun ,function-name (&optional (env *cmp-env*)) ,@(and doc (list doc)) - (and ,@expressions)))))))) + (let ((bits (cmp-env-policy env))) + (and (logtest bits ,bits-on) + (not (logtest bits ,bits-off)) + ,@extra))))))))) + +(define-policy base-camp) (define-policy assume-no-errors :off safety 2) @@ -188,3 +295,13 @@ INTGERP, STRINGP.") (defun compiler-push-events () (>= (cmp-env-optimization 'safety) 3)) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (print 'hola) + (let ((*print-base* 2)(*print-circle* t)) + (maphash #'(lambda (k v) (print (list k v))) + c::*optimization-quality-switches*) + (terpri) + (loop for q in '(debug safety speed space) + do (print (list* q (gethash q c::*optimization-quality-switches*)))) + (print (c::default-policy))))