;-*- Mode: Lisp; Package: ccl -*-
;
;; ****************************************************************
;; MINIMIZE-CONSING.LISP
;; Features to minimize run-time consing
;;
;; Author: Terje Norderhaug (Media Design in*Progress)
;; Email:  terje@in-progress.com
;; URL: <http://www.in-progress.com/src/>
;;
;; Copyright (C) 2002-2003 Terje Norderhaug and Media Design in*Progress.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Library General Public
;; License version 2 as published by the Free Software Foundation.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Library General Public License version 2 for details.
;; 
;; The GNU Library General Public License is available on the web
;; from <http://www.gnu.org/copyleft/lgpl.html> or by writing to the
;; Free Software Foundation, Inc., 59 temple Place - Suite 330,
;; Boston, MA 02111-1307, USA. 
;;
;; Note that this is a different license from the more restrictive GNU GPL license.
;; If this license by any reason doesn't suit your needs, contact
;; the copyright holder of this library by sending an email to Terje Norderhaug 
;; at <terje@in-progress.com>. Please submit modifications of
;; the library to the same address. Any submitted modifications will 
;; automatically fall under the terms of this license unless otherwise specified.
;;
;; Thanks to Alan Ruttenberg (MIT Media Lab) for the macro-callers.lisp MCL constribution, 
;; which was used as inspiration for parts of this implementation. One day, perhaps MCL 
;; itself could store information about the extent of function arguments in an optimized 
;; way such as on the lfun...
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; VERSION HISTORY
;;
;; Jan-06-2002 TN Version 0.7b released

(in-package :ccl)

(export 'argument-dynamic-extent-p)
(export 'minimizing-consing)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def-accessors (afunc) %svref
  ()                                    ; 'afunc
  afunc-acode
  afunc-parent
  afunc-vars
  afunc-inherited-vars
  afunc-blocks
  afunc-tags
  afunc-inner-functions
  afunc-name
  afunc-bits
  afunc-lfun
  afunc-environment
  afunc-lambdaform
  afunc-argsword
  afunc-ref-form
  afunc-warnings
  afunc-fn-refcount
  afunc-fn-downward-refcount
  afunc-all-vars
  afunc-callers
  afunc-vcells
  afunc-fcells
  afunc-fwd-refs
  afunc-lfun-info
  afunc-linkmap
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RECORDING AND ASSESSING DYNAMIC EXTENT DECLARATIONS

#| The following enables the compiler to record the dynamic extent declarations 
of function arguments. Using that information one can reasonable quickly determine
(even at runtime) whether an argument has dynamic extent, allowing optimalization 
that eliminates unecessarry consing of the values passed to the function.
 
The declarations are stored in the same way as local symbol information is, so they are
recorded in fasls, and are available even outside the compilation environment.
 
The variable *save-function-declarations*, which defaults to t, controls whether or
not this information is recorded. In order for it to work, you must also
have *save-local-symbols* and *fasl-save-local-symbols* also set to t.
|#

(defvar *save-function-declarations* T)

(defun argument-dynamic-extent-p (fun symbol/index)
   "True if the argument to the function is declared to have dynamic extent (returns 'ignore if the argument is ignored)"
  (multiple-value-bind (declarations keys)
   (function-declarations fun)
    (when declarations
      (if (fixnump symbol/index)
        (cdr (svref (the vector declarations) (the fixnum symbol/index)))
        (cdr (or (find symbol/index (the vector declarations) :key #'car :test #'eq)
                 (when keys
                   (let ((pos (position symbol/index (the vector keys) :test #'eq)))
                     (when pos
                       (svref (the vector declarations) 
                              (the fixnum (+ pos (- (length (the vector declarations))
                                                    (length (the vector keys)))))))))))))))

(defun function-declarations (function)
  "Returns the argument declarations of the function as a vector, with a vector of its keywords in the same order as second value"
  ;; using a proxy boosted the speed several times!
  (let ((proxy #.(make-hash-table :test #'eq  :weak :key)))
   ((lambda (value)
      ; faster than using values-list:
      (when value
        (values (first value) (second value))))
    (multiple-value-bind (value found)
      (gethash function proxy)
      (if found
        value
        (setf (gethash function proxy)
              (flet ((%function-declarations (function)
                       (list
                        (getf (%lfun-info function) :argument-declarations)
                        (lfun-keyvect function))))
                (etypecase function
                    (compiled-lexical-closure
                     (%function-declarations (closure-function function)))
                    (compiled-function
                     (if (lfunp function)
                       (%function-declarations function)
                       (%function-declarations (fdefinition function))))
                    (standard-method
                     (%function-declarations (method-function function)))))))))))

(defun lambda-argument-declarations (lambda)
  "Generates an argument declarations representation from a lambda expression"
  (multiple-value-bind (form declarations)
                       (parse-body (cddr lambda) nil)
    (declare (ignore form))
    (let (dynamic-extent-args ignored-args)
      (dolist (spec (decl-specs-from-declarations declarations))
        (case (car spec)
          (dynamic-extent
           (setf dynamic-extent-args
                 (append (cdr spec) dynamic-extent-args)))
          (ignore 
           (setf ignored-args
                 (append (cdr spec) ignored-args)))))
      (values
       (when (or dynamic-extent-args ignored-args)
         (apply #'vector
                (loop for arg in (remove-if 
                                  (lambda (arg)
                                    (member arg '(&optional &key &rest)))
                                  (remove (second (member '&rest (second lambda)))
                                          (second lambda)))
                      collect (cons arg (cond
                                         ((member arg ignored-args)
                                          'ignore)
                                         ((member arg dynamic-extent-args)
                                          'dynamic-extent))))))
       (let ((keys (cdr (member '&key (second lambda)))))
         (when keys
           (apply #'vector
                  (mapcar (lambda (key)
                            (make-keyword (if (consp key) (car key) key)))
                          keys))))))))

(unadvise nx1-compile-lambda   
  :when :around
  :name :record-arg-declarations)

(advise nx1-compile-lambda
  (let ((ret (multiple-value-list (:do-it))))
    (when *save-function-declarations*
      (let ((name (first arglist))
            (lambda (second arglist))
            (afunc (third arglist)))
        (declare (ignore name afunc))
        (let ((declarations (lambda-argument-declarations lambda)))
          (when declarations
            (setf (afunc-lfun-info (car ret))
                  (list* :argument-declarations
                         declarations
                         (afunc-lfun-info (car ret))))))))
    (values-list ret))
  :when :around
  :name :record-arg-declarations)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MINIMIZE CONSING

#| A frequently used technique to minimize consing in Common LISP applications is to declare certain 
function arguments to have dynamic extent where a function is called. This involves knowing which 
arguments won't be used beyond the extent of the call, binding these arguments to local variables,
when declare the variables to have dynamic extent.

Minimizing consing by manually declaring function call arguments to have dynamic-extent has several
problems. It is tedious to modify the code and the result can be messy and error-prone, as 
a simple function call is complicated with one or more variable bindings. It requires the developer
to have intimate knowledge of the function called, or make guesses about the extent of its arguments.
If the implementation of a function changes so that some arguments no longer have dynamic extent,
optimized calls that depend on the argument extents of the original version will have to be updated
or else may cause serious problems at runtime.

The MINIMIZE-CONSING macro automates cons minimalization of function calls. It moves the responsibility
for declaring dynamic extent arguments to the function. This makes the code cleaner and easier to
maintain. Although it still is possible to cause an optimized function call to be invalid by modifying
the called function, recompiling the function call automatically updates the code. Future versions
may resolve this by automatically recompiling optimized function calls or at least provide a warning.

CLtL2 section 9.2 "Declaration Specifiers" discusses optimizing function calls based on dynamic extent 
declarations of function arguments. See also section 3.3.3 of Common LISP HyperSpec for more about the 
same issue. The last paragraph in Hyperspec issue DYNAMIC-EXTENT-FUNCTION is also interesting, 
suggesting ways to automatically determine when a closure can have dynamic extent.
|#

(defvar *minimize-consing* t)

(defmacro minimize-consing (&rest forms &environment env &aux (*minimize-key-consing* t))
  (flet ((local-function-declarations (name)
           (let ((afunc (third (assq name (lexenv.functions env)))))
             (when afunc
               (lambda-argument-declarations (afunc-lambdaform afunc))))))
    `(progn
       ,@(loop 
           while forms
           for form = (pop forms)
           when (keywordp form)
           do (case form
                (:deep (warn ":deep ~A not yet supported as option for minimize-consing" (pop forms)))
                (:dynamic-extent-args (warn ":dynamic-extent-args ~A not yet supported as option for minimize-consing" (pop forms)))
                (:minimize-key-consing
                 (setf *minimize-key-consing*
                       (pop form)))
                (otherwise (warn "Unknown option ~A ~A used in minimize-consing" (pop forms))))
           when (consp form)
           collect
           (labels ((variablep (form)
                      (and (symbolp form)
                           (not (keywordp form))
                           (not (constantp form))))
                    (dynamic-extent-recommended-p (form)
                      "True if it makes sense to optimize the form by declaring the result value to have dynamic extent"
                      ;; never deny any form with side effects as it needs to be evaluated in order!
                      (or 
                       (consp form)
                       (variablep form)  ;; variables need to be handled in argument order as they might be set by side effect!
                       (functionp form))))
            (let ((form (macroexpand form env)))
             (cond
               ((or (not *minimize-consing*)
                    (= (safety-optimize-quantity env) 3))
                form)
               ((eq (first form) 'funcall)
                (let* ((fun (gensym "FUNCTION"))
                       (decl (gensym "DECLARATIONS"))
                       (keys (gensym "KEYS"))
                       (nreg (gensym "NREG"))
                       (args (cddr form))
                       (varlist (loop for arg in args
                                      for i from 0
                                      collect (if (dynamic-extent-recommended-p arg)
                                                (gensym (format nil "ARG~A-" i))
                                                arg)))
                       (minimize-key-consing (and *minimize-key-consing*
                                                      ; cdr as first arg would be a keyword!
                                                      (member-if #'dynamic-extent-recommended-p (cdr args)))))
                 (if (not (member-if #'dynamic-extent-recommended-p args))
                   form
                   (labels ((build (&optional (i 0) &aux (bind-call (gensym "BINDCALL")))
                             (let ((i (position-if #'dynamic-extent-recommended-p args :start i)))
                               (if (not i)
                                 `(funcall ,fun ,@varlist)
                                 (let ((var (nth i varlist))
                                       (arg (nth i args)))
                                   `(flet ((,bind-call (,var)
                                             ,(build (1+ i))))
                                      (declare ,@(unless (< (speed-optimize-quantity env)
                                                            (space-optimize-quantity env))
                                                   `((inline ,bind-call))) ; major speed improvement but makes executable grow to the power of two.
                                               (dynamic-extent (function ,bind-call)))
                                      ,(cond
                                       ((variablep arg)
                                        ;; variables need to be handled in order as they can be set by other argument forms!
                                        `(locally
                                          (declare (inline ,bind-call)) ; no worry about the space here!
                                          (,bind-call ,arg)))
                                       (T 
                                         `(if (and 
                                               ,decl
                                               ,(if (= i 0)
                                                  `(cdr (svref (the vector ,decl) ,i))
                                                  `(if (< ,i ,nreg) ;; ## also use oddp on mod 2 (- i nkeys) to determine valid pso for keywords!
                                                     (cdr (svref (the vector ,decl) ,i))
                                                     ,(when minimize-key-consing
                                                        (let ((key (nth (1- i) args)))
                                                          (when (keywordp key) ;; # should allow symbols in any package as keys!
                                                            `(when ,keys
                                                               (cdr (the cons
                                                                      (svref (the vector ,decl)
                                                                             (the fixnum
                                                                               (+ ,nreg 
                                                                                  (the fixnum
                                                                                    (position ,key (the vector ,keys) 
                                                                                              :test #'eq))))))))))))))
                                            (let ((,var ,arg))
                                              (declare (dynamic-extent ,var))
                                              (,bind-call ,var))
                                            (,bind-call ,arg))))))))))
                            `(let* ((,fun ,(second form)))
                               (declare (dynamic-extent ,fun))
                               ;; This takes a lot of the time:
                               (multiple-value-bind (,decl ,@(when minimize-key-consing (list keys)))
                                                    (function-declarations ,fun)
                                 (let ,(when minimize-key-consing
                                         `((,nreg (- (the fixnum (length ,decl))
                                                     (the fixnum (length ,keys))))))
                                   (declare (fixnum ,nreg))
                                   ,(build))))))))
                ((or (function-call-p form)
                     (local-function-declarations (car form)))
                 (let ((name (car form))
                       (args (cdr form)))
                   (multiple-value-bind (decl keys)
                     (if (local-function-declarations name) 
                       (local-function-declarations name)
                       (function-declarations (symbol-function name)))
                     (let* ((nreg (- (length decl)(length keys)))
                            (bindings
                             (append
                              (loop for i from 0 below (min nreg (length args))
                                    collect (list (car (svref decl i))
                                                  (nth i args)))
                              (if keys
                                (loop with keyargs = (subseq args nreg)
                                      while keyargs
                                      for key = (pop keyargs)
                                      for value = (pop keyargs)
                                      collect (list
                                               (or (car (find key decl :start nreg :key #'car :test #'string-equal))
                                                   (gensym (string key))) 
                                               value))
                                (loop with rest = (subseq args nreg)
                                      while rest
                                      collect (list (gensym)(pop rest))))))
                            (argvars
                             (mapcar #'car bindings)))
                       `(let ,bindings
                          (declare (dynamic-extent 
                                    ,@(remove-if-not 
                                       (lambda (var)
                                         (cdr (find var decl :key #'car)))
                                       argvars)))
                          (,(car form) 
                           ,@(if keys 
                               (append
                                (subseq argvars 0 nreg)
                                (loop with keyargs = (subseq args nreg)
                                      for var in (subseq argvars nreg)
                                      collect (pop keyargs)
                                      collect var
                                      do (pop keyargs)))
                               argvars)))))))
                (T
                 form))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TESTING

#|

(defun test (value)
  (flet ((foo (argument)
           (declare (dynamic-extent argument))
           (car argument)))
    (minimize-consing
     (foo (cons value value)))))

(time (test 'x))

(defun foo (arg1 arg2 &optional arg3 &rest rest &key arg4 arg5)
  (declare (dynamic-extent arg1 arg4))
  (declare (ignore arg2 rest arg5))
  (when (and arg1 arg3 arg4) T)
)

(defun test (value)
  (foo (cons :value value) (lambda (arg)(+ arg value)) nil :arg5 (cons value :value)))

(time (dotimes (i 100000)(test 1)))

(defun test (value)
  (minimize-consing
   (foo (cons :value value) (lambda (arg)(+ arg value)) nil :arg5 (cons value :value))))

(time (dotimes (i 100000)(test 1)))

(defparameter *foo* #'foo)

(defun test (value)
  (minimize-consing
   (funcall *foo* (cons :value value) (lambda (arg)(+ arg value)) nil :arg5 (cons value :value))))

(time (dotimes (i 100000)(test 1)))

(pprint
 (macroexpand 
  '(minimize-consing
    (foo (cons :value value) (lambda (arg)(+ arg value)) NIL :arg5 (cons value :value))
    (funcall #'foo (cons :value value) (lambda (arg)(+ arg value)) NIL :arg5 (cons value :value))
    ))
 *debug-io*)

|#