;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Library General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 2 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../Copyright' for full details.

;;;; CMPINLINE  Open coding optimizer.

(in-package "COMPILER")

;;; Valid property names for open coded functions are:
;;;  :INLINE-ALWAYS
;;;  :INLINE-SAFE	safe-compile only
;;;  :INLINE-UNSAFE	non-safe-compile only
;;;
;;; Each property is a list of 'inline-info's, where each inline-info is:
;;; ( types { type | boolean } { string | function } ).
;;;
;;; For each open-codable function, open coding will occur only if there exits
;;; an appropriate property with the argument types equal to 'types' and with
;;; the return-type equal to 'type'.  The third element
;;; is T if and only if side effects may occur by the call of the function.
;;; Even if *DESTINATION* is TRASH, open code for such a function with side
;;; effects must be included in the compiled code.
;;; The forth element is T if and only if the result value is a new Lisp
;;; object, i.e., it must be explicitly protected against GBC.

(defun make-inline-temp-var (expected-type value-type &optional rep-type)
  (let ((out-rep-type (or rep-type (lisp-type->rep-type expected-type))))
    (if (eq out-rep-type :object)
        (make-temp-var)
        (let ((var (make-lcl-var :rep-type out-rep-type
                                 :type (type-and expected-type value-type))))
          (wt-nl "{" (rep-type-name out-rep-type) " " var ";")
          (incf *inline-blocks*)
          var))))

(defun emit-inlined-variable (form expected-type rest-forms)
  (let ((var (c1form-arg 0 form))
        (value-type (c1form-primary-type form)))
    (if (var-changed-in-form-list var rest-forms)
        (let* ((temp (make-inline-temp-var expected-type value-type
                                           (var-rep-type var))))
          (let ((*destination* temp)) (set-loc var))
          (list value-type temp))
        (list value-type var))))

(defun emit-inlined-setq (form expected-type rest-forms)
  (let ((vref (c1form-arg 0 form))
        (form1 (c1form-arg 1 form)))
    (let ((*destination* vref)) (c2expr* form1))
    (if (eq (c1form-name form1) 'LOCATION)
        (list (c1form-primary-type form1) (c1form-arg 0 form1))
        (emit-inlined-variable (make-c1form 'VAR form vref) expected-type rest-forms))))

(defun emit-inlined-call-global (form expected-type)
  (let* ((fname (c1form-arg 0 form))
         (args (c1form-arg 1 form))
         (return-type (c1form-primary-type form))
         (fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p))
         (loc (call-global-loc fname fun args return-type expected-type))
         (type (loc-type loc))
         (temp (make-inline-temp-var expected-type type
                                     (loc-representation-type loc)))
         (*destination* temp))
    (set-loc loc)
    (list type temp)))

(defun emit-inlined-progn (form expected-type forms)
  (let ((args (c1form-arg 0 form)))
    (loop with *destination* = 'TRASH
       while (rest args)
       do (c2expr* (pop args)))
    (emit-inline-form (first args) expected-type forms)))

(defun emit-inlined-values (form expected-type forms)
  (let ((args (c1form-arg 0 form)))
    (prog1 (emit-inline-form (pop args) expected-type forms)
      (loop with *destination* = 'TRASH
         for form in args
         do (c2expr* form)))))

(defun emit-inlined-structure-ref (form expected-type rest-forms)
  (let ((type (c1form-primary-type form)))
    (if (args-cause-side-effect rest-forms)
        (let* ((temp (make-inline-temp-var expected-type type))
               (*destination* temp))
          (c2expr* form)
          (list type temp))
        (list type
              (list 'SYS:STRUCTURE-REF
                    (first (coerce-locs
                            (inline-args (list (c1form-arg 0 form)))))
                    (c1form-arg 1 form)
                    (c1form-arg 2 form)
                    (c1form-arg 3 form))))))

(defun emit-inlined-instance-ref (form expected-type rest-forms)
  (let ((type (c1form-primary-type form)))
    (if (args-cause-side-effect rest-forms)
        (let* ((temp (make-inline-temp-var expected-type type))
               (*destination* temp))
          (c2expr* form)
          (list type temp))
        (list type
              (list 'SYS:INSTANCE-REF
                    (first (coerce-locs
                            (inline-args (list (c1form-arg 0 form)))))
                    (c1form-arg 1 form)
                    #+nil (c1form-arg 2 form))))))

(defun emit-inline-form (form expected-type forms)
  (with-c1form-env (form form)
    (case (c1form-name form)
      (LOCATION
       (list (c1form-primary-type form) (c1form-arg 0 form)))
      (VAR
       (emit-inlined-variable form expected-type forms))
      (CALL-GLOBAL
       (emit-inlined-call-global form expected-type))
      (SYS:STRUCTURE-REF
       (emit-inlined-structure-ref form expected-type forms))
      #+clos
      (SYS:INSTANCE-REF
       (emit-inlined-instance-ref form expected-type forms))
      (SETQ
       (emit-inlined-setq form expected-type forms))
      (PROGN
        (emit-inlined-progn form expected-type forms))
      (VALUES
       (emit-inlined-values form expected-type forms))
      (t (let* ((type (c1form-primary-type form))
                (temp (make-inline-temp-var expected-type type)))
           (let ((*destination* temp)) (c2expr* form))
           (list type temp))))))

;;;
;;; inline-args:
;;;   returns a list of pairs (type loc)
;;;   side effects: emits code for temporary variables
;;;
;;; Whoever calls inline-args must bind *inline-blocks* to 0 and afterwards
;;; call close-inline-blocks
;;;
(defun inline-args (forms &optional types)
  (loop for form-list on forms
     for form = (first form-list)
     for expected-type = (if types (pop types) t)
     collect (emit-inline-form form expected-type (rest form-list))))

(defun destination-type ()
  (rep-type->lisp-type (loc-representation-type *destination*))
  ;;(loc-type *destination*)
)

;;;
;;; inline-function:
;;;   locs are typed locs as produced by inline-args
;;;   returns NIL if inline expansion of the function is not possible
;;;
(defun inline-function (fname arg-types return-type &optional (return-rep-type 'any))
  ;; Those functions that use INLINE-FUNCTION must rebind
  ;; the variable *INLINE-BLOCKS*.
  (and (inline-possible fname)
       (not (get-sysprop fname 'C2))
       (let* ((dest-rep-type (loc-representation-type *destination*))
              (dest-type (rep-type->lisp-type dest-rep-type))
              (ii (get-inline-info fname arg-types return-type return-rep-type)))
         ii)))

(defun apply-inline-info (ii inlined-locs)
  (let* ((arg-types (inline-info-arg-types ii))
         (out-rep-type (inline-info-return-rep-type ii))
         (out-type (inline-info-return-type ii))
         (side-effects-p (function-may-have-side-effects (inline-info-name ii)))
         (fun (inline-info-expansion ii))
         (one-liner (inline-info-one-liner ii)))
    (produce-inline-loc inlined-locs arg-types (list out-rep-type)
                        fun side-effects-p one-liner)))

(defun choose-inline-info (ia ib return-type return-rep-type)
  (cond
    ;; Only accept inliners that have the right rep type
    ((not (or (eq return-rep-type 'any)
              (eq return-rep-type :void)
              (let ((info-type (inline-info-return-rep-type ib)))
                (or (eq return-rep-type info-type)
                    ;; :bool can be coerced to any other location type
                    (eq info-type :bool)))))
     ia)
    ((null ia)
     ib)
    ;; Keep the first one, which is typically the least safe but fastest. 
    ((equal (inline-info-arg-types ia) (inline-info-arg-types ib))
     ia)
    ;; More specific?
    ((every #'type>= (inline-info-arg-types ia) (inline-info-arg-types ib))
     ib)
    ;; Keep the first one, which is typically the least safe but fastest. 
    (t
     ia)))

(defun get-inline-info (fname types return-type return-rep-type)
  (declare (si::c-local))
  (let ((output nil))
    (unless (safe-compile)
      (dolist (x (get-sysprop fname ':INLINE-UNSAFE))
        (let ((other (inline-type-matches x types return-type)))
          (when other
            (setf output (choose-inline-info output other return-type return-rep-type))))))
    (dolist (x (get-sysprop fname ':INLINE-SAFE))
      (let ((other (inline-type-matches x types return-type)))
        (when other
          (setf output (choose-inline-info output other return-type return-rep-type)))))
    (dolist (x (get-sysprop fname ':INLINE-ALWAYS))
      (let ((other (inline-type-matches x types return-type)))
        (when other
          (setf output (choose-inline-info output other return-type return-rep-type)))))
    output))

(defun to-fixnum-float-type (type)
  (dolist (i '(FIXNUM DOUBLE-FLOAT SINGLE-FLOAT
               #+short-float SHORT-FLOAT #+long-float LONG-FLOAT)
           nil)
    (when (type>= i type)
      (return i))))

(defun maximum-float-type (t1 t2)
  (cond ((null t1)
         t2)
        #+long-float
        ((or (eq t1 'LONG-FLOAT) (eq t2 'LONG-FLOAT))
         'LONG-FLOAT)
        ((or (eq t1 'DOUBLE-FLOAT) (eq t2 'DOUBLE-FLOAT))
         'DOUBLE-FLOAT)
        ((or (eq t1 'SINGLE-FLOAT) (eq t2 'SINGLE-FLOAT))
         'SINGLE-FLOAT)
        #+short-float
        ((or (eq t1 'SHORT-FLOAT) (eq t2 'SHORT-FLOAT))
         'SHORT-FLOAT)
        (T
         'FIXNUM)))

(defun inline-type-matches (inline-info arg-types return-type)
  (let* ((rts nil)
         (number-max nil))
    ;;
    ;; Check that the argument types match those of the inline expression
    ;;
    (do* ((arg-types arg-types (cdr arg-types))
          (types (inline-info-arg-types inline-info) (cdr types)))
         ((or (endp arg-types) (endp types))
          (when (or arg-types types)
            (return-from inline-type-matches nil)))
      (let* ((arg-type (first arg-types))
             (type (first types)))
        (cond ((eq type 'FIXNUM-FLOAT)
               (let ((new-type (to-fixnum-float-type arg-type)))
                 (unless new-type
                   (return-from inline-type-matches nil))
                 (push new-type rts)
                 (setq number-max (maximum-float-type number-max new-type))))
              ((type>= type arg-type)
               (push type rts))
              (t (return-from inline-type-matches nil)))))
    ;;
    ;; Now there is an optional check of the return type. This check is
    ;; only used when enforced by the inliner.
    ;;
    (when (or (eq (inline-info-return-rep-type inline-info) :bool)
              (null (inline-info-exact-return-type inline-info))
              (let ((inline-return-type (inline-info-return-type inline-info)))
                (if number-max
                    ;; for arithmetic operators we take the maximal
                    ;; type as possible result type. Note that FIXNUM
                    ;; is not an option, because the product, addition
                    ;; or difference of fixnums may be a larger
                    ;; integer.
                    (and (setf number-max (if (eq number-max 'fixnum)
                                              'integer
                                              number-max))
                         (type>= inline-return-type number-max)
                         (type>= number-max return-type))
                    ;; no contravariance
                    (type>= inline-return-type return-type))))
      (let ((inline-info (copy-structure inline-info)))
        (setf (inline-info-arg-types inline-info)
              (nreverse rts))
        inline-info))))

(defun close-inline-blocks ()
  (dotimes (i *inline-blocks*) (declare (fixnum i)) (wt #\})))

(defun form-causes-side-effect (form)
  (c1form-side-effects form))

(defun args-cause-side-effect (forms)
  (some #'c1form-side-effects forms))

(defun function-may-have-side-effects (fname)

  (not (get-sysprop fname 'no-side-effects)))

(defun function-may-change-sp (fname)
  (not (or (get-sysprop fname 'no-side-effects)
	   (get-sysprop fname 'no-sp-change))))