;;;; compiler optimization policy stuff

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!C")

;;; a value for an optimization declaration
(def!type policy-quality () '(integer 0 3))

;;; global policy restrictions as a POLICY object or nil
(defvar *policy-restrictions* nil)

;;; ** FIXME: The check in ADVISE-IF-REPEATED-OPTIMIZE-QUALITIES fails
;;; spuriously when you restrict the policy.
;;; It asserts that you did not specify some quality value that is not the
;;; effective value for the quality after processing all declarations,
;;; because if it isn't, then there must have been an ignored duplicate.
;;; So any value you specify other than the floor appears as if it got ignored.

(defun restrict-compiler-policy (&optional quality (min 0))
  #!+sb-doc
  "Assign a minimum value to an optimization quality. QUALITY is the name of
the optimization quality to restrict, and MIN (defaulting to zero) is the
minimum allowed value.

Returns the alist describing the current policy restrictions.

If QUALITY is NIL or not given, nothing is done.

Otherwise, if MIN is zero or not given, any existing restrictions of QUALITY
are removed. If MIN is between one and three inclusive, it becomes the new
minimum value for the optimization quality: any future proclamations or
declarations of the quality with a value less then MIN behave as if the value
was MIN instead.

This is intended to be used interactively, to facilitate recompiling large
bodies of code with eg. a known minimum safety.

See also :POLICY option in WITH-COMPILATION-UNIT.

EXPERIMENTAL INTERFACE: Subject to change."
  (declare (type policy-quality min))
  (when quality
    ;; FIXME: If this is an interface, it should be ERROR, not AVER.
    (aver (policy-quality-name-p quality))
    (unless *policy-restrictions*
      (setf *policy-restrictions* (make-policy 0 0)))
    (alter-policy *policy-restrictions* (policy-quality-name-p quality)
                  min (plusp min)))
  ;; Return dotted pairs, not elements that look declaration-like.
  (mapc (lambda (x) (rplacd x (cadr x)))
        (policy-to-decl-spec *policy-restrictions*)))

(defstruct (policy-dependent-quality (:copier nil))
  (name nil :type symbol :read-only t)
  (expression nil :read-only t)
  (getter nil :read-only t)
  (values-documentation nil :read-only t))

;;; names of recognized optimization policy qualities
(declaim (simple-vector **policy-primary-qualities**
                        **policy-dependent-qualities**))
(!defglobal **policy-primary-qualities**
        #(;; ANSI standard qualities
          compilation-speed
          debug
          safety
          space
          speed
          ;; SBCL extensions
          ;;
          ;; FIXME: INHIBIT-WARNINGS is a misleading name for this.
          ;; Perhaps BREVITY would be better. But the ideal name would
          ;; have connotations of suppressing not warnings but only
          ;; optimization-related notes, which is already mostly the
          ;; behavior, and should probably become the exact behavior.
          ;; Perhaps INHIBIT-NOTES?
          inhibit-warnings))
(defglobal **policy-dependent-qualities** #())
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant n-policy-primary-qualities (length **policy-primary-qualities**))
  ;; 1 bit per quality is stored to indicate whether it was explicitly given
  ;; a value in a lexical policy. In addition to the 5 ANSI-standard qualities,
  ;; SBCL defines one more "primary" quality and 16 dependent qualities.
  ;; Both kinds take up 1 bit in the mask of specified qualities.
  (defconstant max-policy-qualities 32))

;; Each primary and dependent quality policy is assigned a small integer index.
;; The POLICY struct represents a set of policies in an order-insensitive way
;; that facilitates quicker lookup than scanning an alist.
(defstruct (policy (:constructor make-policy
                                 (primary-qualities &optional presence-bits)))
  ;; Mask with a 1 for each quality that has an explicit value in this policy.
  ;; Primary qualities fill the mask from left-to-right and dependent qualities
  ;; from right-to-left.
  ;; xc has trouble folding this MASK-FIELD, but it works when host-evaluated.
  (presence-bits #.(mask-field
                    (byte n-policy-primary-qualities
                          (- max-policy-qualities n-policy-primary-qualities))
                    -1)
                 :type (unsigned-byte #.max-policy-qualities))
  ;; For efficiency, primary qualities are segregated because there are few
  ;; enough of them to fit in a fixnum.
  (primary-qualities 0 :type (unsigned-byte #.(* 2 n-policy-primary-qualities)))
  ;; 2 bits per dependent quality is a fixnum on 64-bit build, not on 32-bit.
  ;; It would certainly be possible to constrain this to storing exactly
  ;; the 16 currently defined dependent qualities,
  ;; but that would be overly limiting.
  (dependent-qualities 0
   :type (unsigned-byte #.(* (- max-policy-qualities n-policy-primary-qualities)
                             2))))

;; Return POLICY as a list suitable to the OPTIMIZE declaration.
;; If FORCE-ALL then include qualities without an explicit value too.
(defun policy-to-decl-spec (policy &optional (raw t) force-all)
  (loop with presence = (policy-presence-bits policy)
        for index from (- n-policy-primary-qualities)
        below (length **policy-dependent-qualities**)
        when (or force-all (logbitp (mod index max-policy-qualities) presence))
        collect
       (list (if (minusp index)
                 (elt **policy-primary-qualities** (lognot index))
                 (policy-dependent-quality-name
                  (elt **policy-dependent-qualities** index)))
             (if raw
                 ;; Raw values are insensitive to *POLICY-RESTRICTIONS*.
                 (if (minusp index)
                     (let ((byte-pos (* (lognot index) 2)))
                       (ldb (byte 2 byte-pos)
                            (policy-primary-qualities policy)))
                     (let ((byte-pos (* index 2)))
                       (ldb (byte 2 byte-pos)
                            (policy-dependent-qualities policy))))
                 (%policy-quality policy index)))))

(defmethod print-object ((self policy) stream)
  (if *print-readably*
      (call-next-method)
      (print-unreadable-object (self stream :type t)
        (write (policy-to-decl-spec self) :stream stream))))

;; Return T if P1 and P2 are policies which are specified to be the same.
;; A result of NIL does not imply that definitely P1 /= P2
;; because a multitude of policies can be effectively equal.
;; [Any dependent quality might be specified the same as its computed
;; value in the absence of an explicit value.]
(defun policy= (p1 p2)
  (or (and p1 p2
           (= (policy-primary-qualities p1) (policy-primary-qualities p2))
           (= (policy-dependent-qualities p1) (policy-dependent-qualities p2))
           (= (policy-presence-bits p1) (policy-presence-bits p2)))
      (and (null p1) (null p2))))

;;; Is X the name of an optimization policy quality?
;;; If it is, return the integer identifier for the quality name.
(defun policy-quality-name-p (x)
  ;; Standard (and non-standard) primary qualities are numbered from -1 down.
  (or (awhen (position x **policy-primary-qualities** :test #'eq)
        (lognot it))
      ;; Dependent qualities are numbered from 0 up.
      (position x **policy-dependent-qualities**
                :key #'policy-dependent-quality-name)))

;; Destructively modify POLICY such that quality INDEX has VALUE,
;; and the specified PRESENTP bit.
(defun alter-policy (policy index value &optional (presentp t))
  (if (minusp index) ; a primary quality
      (setf (ldb (byte 2 (* 2 (lognot index)))
                 (policy-primary-qualities policy)) value)
      (setf (ldb (byte 2 (* 2 index))
                 (policy-dependent-qualities policy)) value))
  ;; Some cross-compilation hosts can't execute (SETF (LOGBITP ...)).
  (setf (ldb (byte 1 (mod index max-policy-qualities))
             (policy-presence-bits policy)) (if presentp 1 0))
  policy)

;;; Is it deprecated?
(defun policy-quality-deprecation-warning (quality)
  (case quality
    ((stack-allocate-dynamic-extent stack-allocate-vector stack-allocate-value-cells)
     (deprecation-warning :late "1.0.19.7" quality '*stack-allocate-dynamic-extent*
                          :runtime-error nil)
     t)
    ((merge-tail-calls)
     (deprecation-warning :early "1.0.53.74" quality nil :runtime-error nil)
     t)
    (otherwise
     nil)))

;;; *POLICY* holds the current global compiler policy information, as
;;; a POLICY object mapping from the compiler-assigned index (unique per
;;; quality name) to quality value.
;;; This used to be an alist, but tail-sharing was never really possible
;;; because for deterministic comparison the list was always freshly
;;; consed so that destructive sorting could be done for canonicalization.
(declaim (type policy *policy*)
         (type (or policy null) *policy-restrictions*))

;; ANSI-specified default of 1 for each quality.
(defglobal **baseline-policy** nil)
;; Baseline policy altered with (TYPE-CHECK 0)
(defglobal **zero-typecheck-policy** nil)

;;; This is to be called early in cold init to set things up, and may
;;; also be called again later in cold init in order to reset default
;;; optimization policy back to default values after toplevel PROCLAIM
;;; OPTIMIZE forms have messed with it.
(defun !policy-cold-init-or-resanify ()
  (setq **baseline-policy**
        (make-policy (loop for i below n-policy-primary-qualities
                           sum (ash #b01 (* i 2))))
        **zero-typecheck-policy**
        (alter-policy (copy-policy **baseline-policy**)
                      #-sb-xc (policy-quality-name-p 'type-check)
                      ;; Eval in the host since cold-init won't have
                      ;; executed any forms in 'policies.lisp'
                      #+sb-xc #.(policy-quality-name-p 'type-check)
                      0))

  ;; CMU CL didn't use 1 as the default for everything,
  ;; but since ANSI says 1 is the ordinary value, we do.
  (setf *policy* (copy-policy **baseline-policy**))
  (setf *policy-restrictions* nil)
  ;; not actually POLICY, but very similar
  (setf *handled-conditions* nil
        *disabled-package-locks* nil))

;;; Look up a named optimization quality in POLICY. This is only
;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED;
;;; it's an error if it's called for a quality which isn't defined.
(defun policy-quality (policy quality-name)
  (let ((number (policy-quality-name-p quality-name)))
    (aver number)
    (%policy-quality policy number)))

(define-compiler-macro policy-quality (&whole form policy quality-name)
  (acond ((and (constantp quality-name)
               ;; CONSTANT-FORM-VALUE can not be called here when building
               ;; the cross-compiler, but EVAL can safely be used
               ;; since our own source code is known not to be screwy.
               (policy-quality-name-p (#-sb-xc-host constant-form-value
                                       #+sb-xc-host eval quality-name)))
          `(%policy-quality ,policy ,it))
         (t
          form)))

;; Return the value for quality INDEX in POLICY.
;; Primary qualities are assumed to exist, however policy-restricting functions
;; can create a POLICY that indicates absence of primary qualities.
;; This does not affect RESTRICT-COMPILER-POLICY because a lower bound of 0
;; can be assumed for everything. SET-MACRO-POLICY might care though.
(defun %policy-quality (policy index)
  (declare (type policy policy)
           (type (integer
                  #.(- n-policy-primary-qualities)
                  #.(- max-policy-qualities n-policy-primary-qualities 1))
                 index))
  (let ((floor *policy-restrictions*))
    (macrolet ((quality-floor (get-byte)
                 `(if floor (ldb (byte 2 byte-pos) (,get-byte floor)) 0)))
      (if (minusp index)
          (let ((byte-pos (* (lognot index) 2)))
            (max (ldb (byte 2 byte-pos) (policy-primary-qualities policy))
                 (quality-floor policy-primary-qualities)))
          (let ((byte-pos (* index 2)))
            (max (if (logbitp index (policy-presence-bits policy))
                     (ldb (byte 2 byte-pos) (policy-dependent-qualities policy))
                     1)
                 (quality-floor policy-dependent-qualities)))))))

;;; syntactic sugar for querying optimization policy qualities
;;;
;;; Evaluate EXPR in terms of the optimization policy associated with
;;; THING. EXPR is a form which accesses optimization qualities by
;;; referring to them by name, e.g. (> SPEED SPACE).
(defmacro policy (thing expr)
  (let* ((n-policy (gensym "N-POLICY-"))
         (binds (loop for name across **policy-primary-qualities**
                      for index downfrom -1
                      collect `(,name (%policy-quality ,n-policy ,index))))
         (dependent-binds
          (loop for info across **policy-dependent-qualities**
                for name = (policy-dependent-quality-name info)
               collect `(,name (let ((,name (policy-quality ,n-policy ',name)))
                                 (if (= ,name 1)
                                     ,(policy-dependent-quality-expression info)
                                     ,name))))))
    `(let* ((,n-policy (%coerce-to-policy ,thing)))
       (declare (ignorable ,n-policy))
       (symbol-macrolet (,@binds
                         ,@dependent-binds)
         ,expr))))

;;; Dependent qualities
(defmacro define-optimization-quality
    (name expression &optional values-documentation documentation)
  (declare (ignorable documentation))
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (let ((number (policy-quality-name-p ',name))
           (item (make-policy-dependent-quality
                  :name ',name
                  :expression ',expression
                  ;; DESCRIBE-COMPILER-POLICY uses the getter
                  :getter (lambda (policy) (policy policy ,expression))
                  :values-documentation ',values-documentation)))
       (if number
           (setf (svref **policy-dependent-qualities** number) item)
           ;; This array is reallocated every time a policy is added,
           ;; but that's fine - it's not a performance issue.
           (let ((size (1+ (length **policy-dependent-qualities**))))
             ;; Don't overrun the packed bit fields.
             (when (> (+ n-policy-primary-qualities size) max-policy-qualities)
               (error "Maximum number of policy qualities exceeded."))
             (setf **policy-dependent-qualities**
                   (replace (make-array size :initial-element item)
                            **policy-dependent-qualities**)))))
     #-sb-xc-host
     ,@(when documentation `((setf (fdocumentation ',name 'optimize) ,documentation)))
     ',name))

;; Set an alternate policy that is used to compile all code within DEFMACRO,
;; MACROLET, DEFINE-COMPILER-MARO - whether they occur at toplevel or not -
;; as well as execute all toplevel code in eval-when situation :COMPILE-TOPLEVEL,
;; including such code as emitted into a '.cfasl' file.
;; e.g. (SET-MACRO-POLICY '((SPEED 0) (SAFETY 3))) ensures full error checking
;; regardless of prevailing local policy in situations such as
;;   (macrolet ((frob (a b) (declare (type (member :up :down) a)) ...)
;;
;; Todo: it would be nice to allow NOTINLINE, which can be broadly achieved by
;; setting (SPEED 0), but nonetheless more targeted settings should be possible.
;; Same for {UN}MUFFLE-CONDITIONS or anything else that can be proclaimed.
;;
(defun set-macro-policy (list)
  ;: Note that *MACRO-POLICY* does not represent absence of any primary quality,
  ;; and therefore whenever it is injected into a macro, you get all baseline
  ;; values of 1, augmented by the specified changes.
  ;; There are two alternative behaviors that might make sense:
  ;; - use the value of *POLICY* when SET-MACRO-POLICY is called as the baseline
  ;;   augmented by the specifiers in LIST
  ;; - use the lexical policy at the time of expansion, augmented by LIST
  ;; But most probably the current behavior is entirely reasonable.
  (setq *macro-policy* (process-optimize-decl `(optimize ,@list)
                                              **baseline-policy**)))

;; Turn the macro policy into an OPTIMIZE declaration for insertion
;; into a macro body for DEFMACRO, MACROLET, or DEFINE-COMPILER-MACRO.
;; Note that despite it being a style-warning to insert a duplicate,
;; we need no precaution against that even though users may write
;;  (DEFMACRO FOO (X) (DECLARE (OPTIMIZE (SAFETY 1))) ...)
;; The expansion of macro-defining forms is such that the macro-policy
;; appears in a different lexical scope from the user's declarations.
(defun macro-policy-decls ()
  (and *macro-policy*
       `((declare (optimize ,@(policy-to-decl-spec *macro-policy*))))))
