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

;;;;
;;;;  CMPARRAY. Optimizations related to arrays

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

(in-package "COMPILER")

;;;
;;; MAKE-ARRAY
;;;

(defun guess-array-element-type (element-type)
  (if (and (setf element-type (extract-constant-value element-type))
           (known-type-p element-type))
      (upgraded-array-element-type element-type *cmp-env*)
      '*))

(defun guess-array-dimensions-type (orig-dimensions &aux dimensions)
  (and (consp orig-dimensions)
       (eq (first dimensions) 'LIST)
       (let ((l (list-length orig-dimensions)))
         (when (and l (< -1 l array-rank-limit))
           (return-from guess-array-dimensions-type
             (make-list (1- l) :initial-element '*)))))
  (let ((dimensions (extract-constant-value orig-dimensions :failed)))
    (cond ((eq dimensions ':failed)
           '*)
          ((typep dimensions 'ext:array-index *cmp-env*)
           (list dimensions))
          ((and (listp dimensions)
                (let ((rank (list-length dimensions)))
                  (and (numberp rank)
                       (< -1 rank array-rank-limit)
                       (every #'(lambda (x) (typep x 'ext:array-index *cmp-env*)) dimensions)
                       (< (apply '* dimensions) array-total-size-limit))))
           dimensions)
          (t
           (cmpwarn "The first argument to MAKE-ARRAY~%~A~%is not a valid set of dimensions" orig-dimensions)
           '*))))

(define-compiler-macro* make-array (&whole form dimensions &key (element-type t)
                                           (initial-element nil initial-element-supplied-p)
                                           (initial-contents nil initial-contents-supplied-p)
                                           adjustable fill-pointer
                                           displaced-to (displaced-index-offset 0))
  ;; This optimization is always done unless we provide content. There
  ;; is no speed, debug or space reason not to do it, unless the user
  ;; specifies not to inline MAKE-ARRAY, but in that case the compiler
  ;; macro should not be used.
  (let* ((dimensions-type (guess-array-dimensions-type dimensions))
         (guessed-element-type (guess-array-element-type element-type)))
    (unless initial-contents-supplied-p
      ;; If the type is known and we can assume it will not change, we
      ;; replace it with the upgraded form.
      (unless (eq guessed-element-type '*)
        (setf element-type `',guessed-element-type))
      ;; Now we choose between making a vector or making a general array.
      ;; It only saves some time, since MAKE-PURE-ARRAY will call MAKE-VECTOR
      ;; if a one-dimensional array is to be created.
      (let ((function 'si:make-pure-array))
        (when (and (listp dimensions-type)
                   (null (rest dimensions-type))
                   (integerp (first dimensions-type)))
          (setf function 'si:make-vector
                dimensions (first dimensions-type)))
        (setf form
              `(,function ,%element-type ,%dimensions ,%adjustable ,%fill-pointer
                          ,%displaced-to ,%displaced-index-offset)))
      ;; Then we may fill the array with a given value
      (when initial-element-supplied-p
        (setf form `(si:fill-array-with-elt ,form ,%initial-element 0 nil)))
      (setf form `(ext:truly-the (array ,guessed-element-type ,dimensions-type)
                                 ,form))))
  form)

;;;
;;; VECTOR-PUSH and VECTOR-PUSH-EXTEND
;;;

(defun expand-vector-push (whole env extend &aux (args (rest whole)))
  (declare (si::c-local)
           (ignore env))
  (ext:with-clean-symbols (value vector index dimension)
    (when (or (eq (first args) 'value) ; No infinite recursion
              (not (policy-open-code-aref/aset)))
      (return-from expand-vector-push
        whole))
    (unless (<= 2
                (length args)
                (if extend 3 2))
      (cmpwarn "Wrong number of arguments passed to function ~A in form: ~A" (first whole) whole)
      (return-from expand-vector-push
        `(si:simple-program-error
          "Wrong number of arguments passed to function ~A in form: ~A" ',(first whole) ',whole)))
    `(let* ((value ,(car args))
            (vector ,(second args)))
       (declare (:read-only value vector)
                (optimize (safety 0)))
       (optional-type-assertion vector vector)
       (let ((index (fill-pointer vector))
             (dimension (array-total-size vector)))
         (declare (fixnum index dimension)
                  (:read-only index dimension))
         (cond ((< index dimension)
                (si:fill-pointer-set vector (ext:truly-the fixnum (+ 1 index)))
                (si:aset vector index value)
                index)
               (t ,(if extend
                       `(vector-push-extend value vector ,@(cddr args))
                       nil)))))))

(define-compiler-macro vector-push (&whole whole &rest args &environment env)
  (expand-vector-push whole env nil))

(define-compiler-macro vector-push-extend (&whole whole &rest args &environment env)
  (expand-vector-push whole env t))

;;;
;;; AREF/ASET
;;;

(define-compiler-macro aref (&whole form array &rest indices &environment env)
  (if (policy-open-code-aref/aset env)
      (expand-aref array indices env)
      form))

(defun expand-aref (array indices env)
  (ext:with-clean-symbols (%array)
    `(let ((%array ,array))
       (declare (:read-only %array)
                (optimize (safety 0)))
       (row-major-aref %array
                       ,(expand-row-major-index '%array indices env)))))

(define-compiler-macro si:aset (&whole form array &rest indices-and-value
                                &environment env)
  (cond ((null indices-and-value)
         (cmpwarn "Too few arguments to SI:ASET form~%~4I~A" form)
         form)
        ((policy-open-code-aref/aset env)
         (let* ((indices (butlast indices-and-value))
                (value (first (last indices-and-value))))
           (expand-aset array indices value env)))
        (t
         form)))

(defun expand-aset (array indices value env)
  (ext:with-unique-names (%array)
    `(let* ((,%array ,array))
       (declare (:read-only ,%array)
                (optimize (safety 0)))
       (si:row-major-aset ,%array ,(expand-row-major-index %array indices env) ,value))))

(define-compiler-macro array-row-major-index (&whole form array &rest indices &environment env)
  (if (policy-open-code-aref/aset env)
      (ext:with-clean-symbols (%array)
        `(let ((%array ,array))
           (declare (:read-only %array)
                    (optimize (safety 0)))
           ,(expand-row-major-index '%array indices env)))
      form))

(defun expand-zero-dim-index-check (a env)
  (if (policy-type-assertions env)
      `(progn
         (optional-type-assertion ,a array)
         (check-expected-rank ,a 0)
         0)
      0))

(defun expand-vector-index-check (a index env)
  (flet ((expansion (a index)
           `(progn
              (optional-type-assertion ,a vector)
              (check-vector-in-bounds ,a ,index)
              ,index)))
    (if (policy-type-assertions env)
        (ext:with-clean-symbols (%array-index)
          `(let ((%array-index ,index))
             (declare (:read-only %array-index))
             ,(expansion a '%array-index)))
        index)))

(defun expand-row-major-index (a indices env)
  (when (null indices)
    (return-from expand-row-major-index
      (expand-zero-dim-index-check a env)))
  (when (null (rest indices))
    (return-from expand-row-major-index
      (expand-vector-index-check a (first indices) env)))
  (let* ((expected-rank (length indices))
         (check (policy-array-bounds-check env))
         (dims (loop for i from 0
                  for index in indices
                  collect `(,(gentemp "DIM") (array-dimension-fast ,a ,i))))
         (dim-names (mapcar #'first dims)))
    (ext:with-clean-symbols (%ndx-var %output-var %dim-var)
      `(let* (,@dims
              (%output-var 0))
         (declare (type ext:array-index %output-var ,@dim-names)
                  (ignorable ,@dim-names))
         ,@(when (policy-type-assertions env)
                 `((optional-type-assertion ,a array)
                   (check-expected-rank ,a ,expected-rank)))
         ,@(loop for i from 0
              for l in indices
              for index in indices
              for dim-var in dim-names
              when (plusp i)
              collect `(setf %output-var
                             (ext:truly-the ext:array-index (* %output-var ,dim-var)))
              collect `(let ((%ndx-var ,index))
                         (declare (ext:array-index %ndx-var))
                         ,(and check `(check-index-in-bounds ,a %ndx-var ,dim-var))
                         (setf %output-var
                               (ext:truly-the ext:array-index (+ %output-var %ndx-var)))))
         %output-var))))

(defmacro check-expected-rank (a expected-rank)
  `(ffi:c-inline
    (,a ,expected-rank) (:object :fixnum) :void
    "if (ecl_unlikely((#0)->array.rank != (#1)))
            FEwrong_dimensions(#0,#1);"
    :one-liner nil))

(defmacro check-index-in-bounds (array index limit)
  `(ffi:c-inline
    (,array ,index ,limit) (:object :fixnum :fixnum) :void
    "if (ecl_unlikely((#1)>=(#2)))
           FEwrong_index(ECL_NIL,#0,-1,ecl_make_fixnum(#1),#2);"
    :one-liner nil))

(defmacro check-vector-in-bounds (vector index)
  `(ffi:c-inline
    (,vector ,index) (:object :fixnum) :void
    "if (ecl_unlikely((#1)>=(#0)->vector.dim))
           FEwrong_index(ECL_NIL,#0,-1,ecl_make_fixnum(#1),(#0)->vector.dim);"
    :one-liner nil))

(defconstant +array-dimension-accessor+
  '#.(loop for i from 0 below array-rank-limit
       collect (format nil "(#0)->array.dims[~D]" i)))

(defun array-dimension-accessor (array n)
  (let ((tails #.(apply 'vector
                   (loop for i from 0 below array-rank-limit
                      for c-code = (format nil "(#0)->array.dims[~D]" i)
                      collect `((:object) :fixnum ,c-code :one-liner t
                                :side-effects nil)))))
    `(ffi:c-inline (,array) ,@(aref tails n))))

(defmacro array-dimension-fast (array n)
  (if (typep n '(integer 0 #.(1- array-rank-limit)) *cmp-env*)
      (array-dimension-accessor array n)
      (error "In macro ARRAY-DIMENSION-FAST, the index is not a constant integer: ~A"
             n)))
