;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

;;;;
;;;;  CMPOPT. Optimization of library functions

;;;;  Copyright (c) 2008. Juan Jose Garcia-Ripol
;;;;
;;;;    See file 'LICENSE' for the copyright details.

(in-package "COMPILER")

;;;
;;; TYPEP
;;;
;;; Some of the type checks can be expanded inline if we know the name
;;; of the type and it corresponds to either a Common-Lisp base type
;;; or to some class.
;;;

(defun expand-in-interval-p (var interval)
  (declare (si::c-local))
  (let ((forms '()))
    (destructuring-bind (&optional (lower-limit '*) (upper-limit '*))
        interval
      (unless (eq lower-limit '*)
        (push (if (consp lower-limit)
                  `(> ,var ,(first lower-limit))
                  `(>= ,var ,lower-limit))
              forms))
      (unless (eq upper-limit '*)
        (push (if (consp upper-limit)
                  `(< ,var ,(first upper-limit))
                  `(<= ,var ,upper-limit))
              forms)))
    forms))

(defun contains-compound-function-type (type)
  (and (consp type)
       (or (eq (first type) 'FUNCTION)
           (and (member (first type) '(NOT OR AND CONS))
                (some #'contains-compound-function-type (rest type))))))

(defun expand-typep (form object type env)
  ;; This function is reponsible for expanding (TYPEP object type)
  ;; forms into a reasonable set of system calls. When it fails to
  ;; match the compiler constraints on speed and space, it simply
  ;; returns the original form. Note that for successful recursion we
  ;; have to output indeed the ORIGINAL FORM, not some intermediate
  ;; step. Otherwise the compiler macro will enter an infinite loop.
  (let* ((orig-type type)
         aux function
         first rest function)
    ;; Type must be constant to optimize
    (if (constantp type env)
        (setf type (cmp-env-search-type (ext:constant-form-value type env) env))
        (return-from expand-typep form))
    (cond ;; compound function type specifier: signals an error
          ((contains-compound-function-type type)
           (cmpwarn "~S is not a valid type specifier for TYPEP" type)
           form)
          ;; Variable declared with a given type
          ((and (symbolp object)
                (setf aux (cmp-env-search-var object env))
                (subtypep (var-type aux) type *cmp-env*))
           t)
          ;; Simple ones
          ((subtypep 'T type *cmp-env*) T)
          ((eq type 'NIL) NIL)
          ;;
          ;; Detect inconsistencies in the provided type. If we run at low
          ;; safety, we will simply assume the user knows what she's doing.
          ((subtypep type NIL *cmp-env*)
           (cmpwarn "TYPEP form contains an empty type ~S and cannot be optimized" type)
           form)
          ;;
          ;; Derived types defined with DEFTYPE. These are expanded
          ;; first so that we can sort out compound function types
          ;; which are equal under si::type= to the atomic function
          ;; type but not allowed in TYPEP.
          ((setq function (si:get-sysprop (if (atom type)
                                              type
                                              (first type))
                                          'SI::DEFTYPE-DEFINITION))
           (expand-typep form object `(quote ,(funcall function (if (atom type)
                                                                    (list type)
                                                                    type)
                                                       env))
                         env))
          ;;
          ;; There exists a function which checks for this type?
          ((setf function (si:get-sysprop type 'si::type-predicate))
           `(,function ,object))
          ;;
          ;; Similar as before, but we assume the user did not give us
          ;; the right name, or gave us an equivalent type.
          ((loop for (a-type . function-name) in si::+known-typep-predicates+
              when (si::type= type a-type *cmp-env*)
              do (return `(,function-name ,object))))
          ;;
          ;; No optimizations that take up too much space unless requested.
          ((not (policy-inline-type-checks))
           form)
          ;;
          ;; CONS types. They must be checked _before_ sequence types. We
          ;; do not produce optimized forms because they can be recursive.
          ((and (consp type) (eq (first type) 'CONS))
           form)
          ;;
          ;; The type denotes a known class and we can check it
          #+clos
          ((and (symbolp type) (setf aux (find-class type nil)))
           `(si::of-class-p ,object ',type))
          ;;
          ;; There are no other atomic types to optimize
          ((atom type)
           form)
          ;;
          ;; (TYPEP o '(NOT t)) => (NOT (TYPEP o 't))
          ((progn
             (setf rest (rest type)
                   first (first type))
             (eq first 'NOT))
           `(not (typep ,object ',(first rest))))
          ;;
          ;; (TYPEP o '(AND t1 t2 ...)) => (AND (TYPEP o 't1) (TYPEP o 't2) ...)
          ;; (TYPEP o '(OR t1 t2 ...)) => (OR (TYPEP o 't1) (TYPEP o 't2) ...)
          ((member first '(OR AND))
           (let ((var (gensym)))
             `(let ((,var ,object))
                (declare (:read-only ,var))
                (,first ,@(loop for type in rest
                           collect `(typep ,var ',type))))))
          ;;
          ;; (TYPEP o '(MEMBER a1 a2 ...)) => (MEMBER o '(a1 a2 ...))
          ((eq first 'MEMBER)
           `(MEMBER ,object ',rest))
          ;;
          ;; (INTEGER * *), etc
          ((member first '(INTEGER RATIONAL FLOAT REAL SINGLE-FLOAT
                           DOUBLE-FLOAT LONG-FLOAT))
           (let ((var1 (gensym))
                 (var2 (gensym)))
             ;; Small optimization: it is easier to check for fixnum
             ;; than for integer. Use it when possible.
             (when (and (eq first 'integer)
                        (subtypep type 'fixnum *cmp-env*))
               (setf first 'fixnum))
             `(LET ((,var1 ,object)
                    (,var2 ,(coerce 0 first)))
                (declare (:read-only ,var1)
                         (type ,first ,var2))
                (AND (TYPEP ,var1 ',first)
                     (locally (declare (optimize (speed 3) (safety 0) (space 0)))
                       (setf ,var2 (ext:truly-the ,first ,var1))
                       (AND ,@(expand-in-interval-p var2 rest)))))))
          ;;
          ;; Compound COMPLEX types.
          ((and (eq first 'COMPLEX)
                (= (list-length type) 2))
           `(and (complexp ,object)
                 (typep (realpart ,object) ',(second type))
                 (typep (imagpart ,object) ',(second type))))
          ;;
          ;; (SATISFIES predicate)
          ((and (eq first 'SATISFIES)
                (= (list-length type) 2)
                (symbolp (setf function (second type))))
           `(,function ,object))
          (t
           form))))

(define-compiler-macro typep (&whole form object type &optional e &environment env)
  (declare (ignore e))
  (expand-typep form object type env))

;;;
;;; DOLIST
;;;
;;; We overwrite the original macros introducing type declarations and
;;; other possible type checks.
;;;

(define-compiler-macro dolist
    ((var expression &optional output-form) &body body &environment env)
  (multiple-value-bind (declarations body)
      (si:process-declarations body nil)
    (let* ((filtered-declarations
            ;; NB: we filter out `type' and `ignore' declarations from
            ;; `dolist', because VAR may be used in the result form
            ;; and its type changes to NIL. These will be placed in
            ;; the output-form (if present).
            (cons `(ignorable ,var)
                  (remove-if (lambda (clause)
                               (and (consp clause)
                                    (or (eq (car clause) 'type)
                                        (eq (car clause) 'ignore))))
                             declarations)))
           (list-var (gensym))
           (typed-var (if (policy-assume-no-errors env)
                          list-var
                          `(ext:truly-the cons ,list-var))))
      `(block nil
         (let* ((,list-var ,expression))
           (si::while ,list-var
             (let ((,var (first ,typed-var)))
               (declare ,@declarations)
               (tagbody ,@body))
             (setq ,list-var (rest ,typed-var)))
           ,(when output-form
              `(let ((,var nil))
                 (declare ,@filtered-declarations)
                 ,output-form)))))))

;;;
;;; COERCE
;;;
;;; Simple coercion rules are implemented using the following
;;; templates.  X is replaced by the coerced value, which can be a
;;; lisp form. We use a LET form to avoid evaluating twice the same
;;; form.
;;;
(defparameter +coercion-table+
  '((integer . (let ((y x)) (check-type y integer) y))
    (float . (float x))
    (short-float  . (float x 0.0s0))
    (single-float . (float x 0.0f0))
    (double-float . (float x 0.0d0))
    (long-float . (float x 0.0l0))
    #+complex-float
    (si:complex-single-float . (let ((y x))
                                 (declare (:read-only y))
                                 (complex (float (realpart y) 0.0f0)
                                          (float (imagpart y) 0.0f0))))
    #+complex-float
    (si:complex-double-float . (let ((y x))
                                 (declare (:read-only y))
                                 (complex (float (realpart y) 0.0d0)
                                          (float (imagpart y) 0.0d0))))
    #+complex-float
    (si:complex-long-float . (let ((y x))
                               (declare (:read-only y))
                               (complex (float (realpart y) 0.0l0)
                                        (float (imagpart y) 0.0l0))))
    (complex . (let ((y x))
                 (declare (:read-only y))
                 (complex (realpart y) (imagpart y))))
    (base-char . (character x))
    (character . (character x))
    (function . (si::coerce-to-function x))))

(defun expand-coerce (form value type env)
  (declare (si::c-local))
  ;; This function is reponsible for expanding (TYPEP object type)
  ;; forms into a reasonable set of system calls. When it fails to
  ;; match the compiler constraints on speed and space, it simply
  ;; returns the original form. Note that for successful recursion we
  ;; have to output indeed the ORIGINAL FORM, not some intermediate
  ;; step. Otherwise the compiler macro will enter an infinite loop.
  (let* ((orig-type type)
         first rest)
    ;; Type must be constant to optimize
    (if (constantp type env)
        (setf type (cmp-env-search-type (ext:constant-form-value type env) env))
        (return-from expand-coerce form))
    (cond ;; Trivial case
          ((subtypep 't type *cmp-env*)
           value)
          ;;
          ;; Detect inconsistencies in the type form.
          ((subtypep type 'nil *cmp-env*)
           (cmperror "Cannot COERCE an expression to an empty type."))
          ;;
          ;; No optimizations that take up too much space unless requested.
          ((not (policy-inline-type-checks))
           form)
          ;;
          ;; Search for a simple template above, replacing X by the value.
          ((loop for (a-type . template) in +coercion-table+
              when (eq type a-type)
              do (return (subst value 'x template))))
          ;;
          ;; Derived types defined with DEFTYPE.
          ((and (atom type)
                (setq first (si:get-sysprop type 'SI::DEFTYPE-DEFINITION)))
           (expand-coerce form value `',(funcall first (list type) env) env))
          ;;
          ;; CONS types are not coercible.
          ((and (consp type)
                (eq (first type) 'CONS))
           form)
          ;;
          ;; Search for a simple template above, but now assuming the user
          ;; provided a more complex form of the same value.
          ((loop for (a-type . template) in +coercion-table+
              when (si::type= type a-type *cmp-env*)
              do (return (subst value 'x template))))
          ;;
          ;; SEQUENCE types
          ((subtypep type 'sequence *cmp-env*)
           (multiple-value-bind (elt-type length)
               (si::closest-sequence-type type)
             (if (or (eq length '*) (policy-assume-right-type))
                 (if (eq elt-type 'list)
                     `(si::coerce-to-list ,value)
                     `(si::coerce-to-vector ,value ',elt-type ',length
                                            ,(and (subtypep type 'simple-array *cmp-env*) t)))
                 form)))
          ;;
          ;; There are no other atomic types to optimize
          ((atom type)
           form)
          ;;
          ;; (TYPEP o '(AND t1 t2 ...)) => (AND (TYPEP o 't1) (TYPEP o 't2) ...)
          ((progn
             (setf rest (rest type) first (first type))
             (eq first 'AND))
           `(let ((x ,value))
              ,@(loop for i in rest
                   collect `(setf x (coerce x ',i)))
              x))
          ;;
          ;; (COMPLEX whatever) types
          ((and (eq first 'complex)
                (= (length rest) 1))
           `(let ((y ,value))
              (declare (:read-only y))
              (complex (coerce (realpart y) ',(first rest))
                       (coerce (imagpart y) ',(first rest)))))
          ;;
          ;; (INTEGER * *), etc We have to signal an error if the type
          ;; does not match. However, if safety settings are low, we
          ;; skip the interval test.
          ((member first '(INTEGER RATIONAL FLOAT REAL SINGLE-FLOAT
                           DOUBLE-FLOAT LONG-FLOAT))
           (let ((unchecked (expand-coerce form value `',first env)))
             (if (policy-assume-no-errors)
                 unchecked
                 `(let ((x ,unchecked))
                    (declare (,first x))
                    (unless (and ,@(expand-in-interval-p 'x (rest type)))
                      (si::do-check-type x ',type nil "coerced value"))
                    x))))
          ;;
          ;; We did not find a suitable expansion.
          (t
           form)
          )))

(define-compiler-macro coerce (&whole form value type &environment env)
  (expand-coerce form value type env))

(define-compiler-macro princ (&whole whole expression &optional stream &environment env)
  (if (constantp expression env)
      (let ((value (ext:constant-form-value expression env)))
        (typecase value
          ((eql #\newline)
           `(terpri ,stream))
          ((string 1)
           `(princ ,(aref value 0) ,stream))
          (otherwise
           whole)))
      whole))
