[Gcl-devel] Automatic inlining and function signature discovery

[Camm Maguire]

Greetings!  We've all discussed before the new facility for
auto-proclaiming and recompiling functions to ensure image consistency
in the HEAD branch of cvs.

Inlining is currently implemented at the lisp level, useing the
compressed save source from initial compilation as necessary.
Heuristics are used to determine whether the function is too large,
which of course can be fine tuned by the user.  To speed things up,
pre-compiled results of pass1 can be stored in a hash table in most
cases. 

As we are also aware, GCL's traditional very useful inlining ability
is based on string processing of hand-edited entries in the plist
under 'inline-always et.el. (e.g. gcl_cmpopt.lsp).  This is hard to
scale to many functions, but I suspect it is quite fast by comparison
with lisp inlining, though I have done no direct comparisons to
check. 

Here is a rudimentary stab at an idea to do the auto-inlining at the
traditional GCL string level, bypassing both level 1 and level 2 of
the compiler.  Plist entries under 'inline-always are automatically
computed once and then stored.

THIS DOES NOT YET WORK ENTIRELY, OR EVEN MOSTLY.  I'm posting the
source here in case anyone feels like commenting or playing with the
idea, and so I don't forget where things left off when I return from
out of the country in 10 days.

The last possible new item I'd like to discuss is cons types, but I'll
leave this for later.

Take care,
=============================================================================
(in-package 'compiler)
(si::use-fast-links nil)
(setq *prop-hash* nil *default-system-p* t)
(defmacro let-pass3 (binds &body body)
  (let ((usual '((*c-vars* nil)
                  (*vs* 0) (*max-vs* 0) (*level* 0) (*ccb-vs* 0) (*clink* nil)
                  (*unwind-exit* (list *exit*))
                  (*value-to-go* *exit*)
                  (*reservation-cmacro* (next-cmacro))
                  (*sup-used* nil)
                  (*restore-avma* nil)
                  (*base-used* nil)
                  (*cs* 0)
                  )))
        (dolist (v binds)
                (or (assoc (car v) usual)
                    (push v usual)))
        (do ((v (setq usual (copy-list usual)) (cdr v)))
            ((null v))
         (let ((tem (assoc (caar v) binds)))
             (if tem (setf (car v) tem))))
        `(let* ,usual ,@body)))

 (defun inline-hasheable (form fms c1)
  (when *prop-hash*
    (let ((cp (member-if 'closure-p fms))
          (vvp (vv-p (if (eq (car (fourth c1)) 'let*) (cddddr (fourth c1)) c1)))
          (rec (and (boundp '*recursion-detected*) (eq *recursion-detected* 
t))))
      (when cp (cmpnote "not hashing ~s due to closure~%" form))
      (when vvp (cmpnote "not hashing ~s due to vv objs~%" form))
      (when rec (cmpnote "not hashing ~s due to recursion~%" form))
      (not (or cp vvp rec)))))

(defun calc-inline-h (form prop fms)
  (let* ((fn (car form))
         (args (cdr form))
         (last (car (last fms)))
         (args (if last (butlast args) args))
         (la   (when last (car (last form))))
         (src (si::function-src fn))
         (src (blla (cadr src) args la (cddr src)))) ;(if (stringp (caddr src)) 
(cdddr src) (cddr src)))))
    (assert-safety src) 
    (let* ((*inline-forms* (mapcar 'cons (cdr form) fms))
           (*src-inline-recursion* (cons fn *src-inline-recursion*))
;          (c1 (c1expr `(inline ,form ,src)))
           (c1 (c1inline (list form src)))
           (sz (c1size c1)))
      (let ((res (list c1 sz (info-type (cadr c1)) fms)))
        (when (inline-hasheable form fms c1) 
          (copy-vars c1)
          (setf (gethash prop *prop-hash*) res))
        (if (acceptable-inline res form (cddr prop)) res (cons nil (cdr 
res)))))))



  
;; (defun get-inline-h (form prop fms)

;;   (let ((h (when *prop-hash* (gethash prop *prop-hash*))))

;;     (when h

;;       (unless (acceptable-inline h form (cddr prop))
;;      (return-from get-inline-h (cons nil (cdr h))))

;;       (let* ((f (car h))
;;           (fms (fms-fix (fourth f) fms))
;;           (al (info-form-alist (car (last h)) fms))
;;           (nfs (mapcar 'cdr al))
;;           (oi (cadr f))
;;           (info (make-info))
;;           (al (cons (cons oi info) al))
;;           (al (cons (cons (caddr f) (with-output-to-string (s) (princ form 
s))) al)))

;;      (set-vars f)
;;      (setf (info-type info) (info-type oi))
;;      (dolist (l nfs) (add-info info (cadr l)))

;;      (cons (sublis al f) (cdr h))))))

(defun ovs (f) 
  (cond ((var-p f) (cons f (ovs (var-aliases f))))
        ((info-p f) (append (ovs (coerce (info-referred-array f) 'list)) 
                            (ovs (coerce (info-changed-array f) 'list))))
        ((atom f) nil)
        ((append (ovs (car f)) (ovs (cdr f))))))

(defun v-replace (s i)
  (let ((r (si::compile-regexp (format nil "V~a[^0-9]" i))))
    (do ((y 0 (+ 2 x))(x 0)) ((< (setq x (si::string-match r s y)) 0))
        (setf (aref s x) #\# (aref s (1+ x)) (code-char (+ (char-code #\0) 
i))))))

(defun label-replace (s) 
  (let ((r #v"T[0-9]+:?;") p)
    (when (>= (setq p (si::string-match r s)) 0)
      (setf (aref s p) #\~)
      (do nil ((< (setq p (si::string-match r s p)) 0) s)
          (setf (aref s p) #\~)))))

(defun make-string-inline (n f)
  (let* ((fms (fourth f))
         (f (car f))
         (i -1)
         (vs (mapcan (lambda (x) 
                       (when x
                         (let ((y (make-var :kind 'lexical :type (info-type 
(cadr x)) :loc 'object)))
                           (setf (var-kind y) (c2var-kind y) (var-loc y) (incf 
i))
                           (list (list 'var (make-info :type (var-type y)) 
(list y nil)))))) fms))
         (al (mapcar 'cons fms vs))
         (f (sublis al f))
         (*exit* nil))
    (mapc (lambda (x) (setf (var-store x) nil)) (remove-duplicates (ovs f)))
;    (print f)(break)
    (let-pass3 
     nil
     (let* ((*exit* (next-label)) (*vind* 0)
            (*unwind-exit* (list* *exit* *unwind-exit*))
            (o (cs-push (info-type (cadr f))))
            (*value-to-go* (list 'cvar o))*sup-used* (*max-vs* 0) (*volatile* 
"")
            (*compiler-output1* (make-string-output-stream))
            (*compiler-output2* (make-string-output-stream)))
       (c2expr f)(wt-label *exit*)(wt-nl "")(wt-cvar o) (wt ";")(wt-cvars)
       (when *sup-used* 
         (wt-h "object *" *volatile* "sup=vs_top+" *max-vs* ";vs_top=sup;"))
       (let ((x (get-output-stream-string *compiler-output1*)))
         (dotimes (i (length vs))
;          (v-replace x (1+ i)))
           (v-replace x i))
         (label-replace x)
         (let* ((z (concatenate 'string "({" (get-output-stream-string 
*compiler-output2*) x "})"))
                (i `(,(mapcar (lambda (x) (info-type (cadr x))) vs) ,(info-type 
(cadr f)) #.(flags rfa) ,z)))
           (push i (get n 'inline-always))))))))

(defun maybe-inline (form c1forms &optional last &aux (*in-inline* t))
  (when (and (not *compiler-new-safety*) (> *speed* 0) (src-inlineable form))
    (let* ((fms (append c1forms (list last)))
           (tpis (mapcar (lambda (x) (when x (cons (info-type (cadr x)) 
(ignorable-form x)))) fms))
           (*compiler-check-args* (>= (this-safety-level) 2))
           (prop (cons (car form) (cons (this-safety-level) tpis))))

      (let* ((ii (get-inline-info (car form) (if last fms c1forms) nil))
             (ti (third ii)))
        (unless (and ii (flag-p ti rfa) (or (not last) ));(flag-p ti apply)
          (make-string-inline (car form) (calc-inline-h form prop fms)))
        (values nil nil)))))

;; (defun maybe-inline (form c1forms &optional last &aux (*in-inline* t))
;;   (when (and (not *compiler-new-safety*) (> *speed* 0) (src-inlineable form))
;;     (let* ((fms (append c1forms (list last)))
;;         (tpis (mapcar (lambda (x) (when x (cons (info-type (cadr x)) 
(ignorable-form x)))) fms))
;;         (*compiler-check-args* (>= (this-safety-level) 2))
;;         (prop (cons (car form) (cons (this-safety-level) tpis))))

;;       (mark-for-hash-inlining fms)

;;       (let ((h (or (get-inline-h  form prop fms) 
;;                 (calc-inline-h form prop fms))))
;;      (make-string-inline (car form) h) (setq h nil)
;;      (values (car h) (caddr h))))))


;; (defun trim-vars (vars forms body &aux (*vars* *vars*))

;;   (do (nv nf nz (vs vars (cdr vs)) (fs forms (cdr fs))) 
;;       ((or (endp vs) (endp fs)) 
;;        (if nf (setf (car nf) (new-c1progn nz (car nf))) (setf body 
(new-c1progn nz body)))
;;        (list nv nf body))
;;       (let ((var (car vs)) (form (car fs)))
;;      (cond ((and (eq (var-kind var) 'LEXICAL)
;;                  (not (eq t (var-ref var))) ;;; This field may be IGNORE.
;;                  (not (var-ref-ccb var)))
;;             (unless (ignorable-form form) (push form nz)))
;;            ((push var nv) 
;;             (if nf (setf (car nf) (new-c1progn nz (car nf))) (setf body 
(new-c1progn nz body)))
;;             (setq nz nil)
;;             (push form nf))))))

;; (defun can-be-replaced (var body)
;;   (and (or (member (var-kind var) '(LEXICAL OBJECT REPLACED))
;;         (and (eq (var-kind var) 'object)
;;              (< (the fixnum (var-register var))
;;                 (the fixnum *register-min*))))
;;        (not (var-cb var))
;;        (not (var-store var))
;;        (not (is-changed var (cadr body)))))

(defvar *label-char* #\a)

(defun gen-fresh-label-char nil
  (if *in-inline* #\~
    (let ((ch (code-char (1+ (char-code *label-char*)))))
      (unless (alpha-char-p ch) (baboon))
      (setq *label-char* ch))))

(defun init-env ()
  (setq *next-cvar* 0)
  (setq *next-cmacro* 0)
  (setq *next-vv* -1)
  (setq *next-cfun* 0)
  (setq *last-label* 0)
  (setq *label-char* #\a)
  (clrhash *objects*)
  (clrhash *objects-rev*)
  (clrhash *dlinks*)
  (setq *constants* nil)
  (setq *local-funs* nil)
  (setq *global-funs* nil)
;  (setq *setf-function-proxy-symbols* nil)
  (setq *global-entries* nil)
  (setq *undefined-vars* nil)
  (setq *reservations* nil)
  (setq *closures* nil)
  (setq *top-level-forms* nil)
  (setq *non-package-operation* nil)
  (setq *function-declarations* nil)
  (setq *inline-functions* nil)
  (setq *inline-blocks* 0)
  (setq *tmp-pack* nil)
  (setq *notinline* nil))

(defun wt-inline-loc (fun locs &aux (i 0) (max -2) (maxv 0) lch)
  (declare (fixnum i max maxv))
  (let* ((others (and (consp fun) (stringp (car fun)) (cdr fun)))
         (fun (if (and (consp fun) (stringp (car fun))) (car fun) fun)))
    (cond ((stringp fun)
           
           (when (char= (char (the string fun) 0) #\@)
             (setq i 1)
             (do ()
                 ((char= (char (the string fun) i) #\;) (incf i))
               (incf i)))
           (do ((size (length (the string fun))))
               ((>= i size))
               (declare (fixnum size))
               (let ((char (char (the string fun) i)))
                 (declare (character char))
                 (cond ((char= char #\~)
                        (princ (setq lch (or lch (gen-fresh-label-char))) 
*compiler-output1*)
                        (incf i))
                       ((char= char #\#)
                        (let ((ch (char (the string fun) (the fixnum (1+ i))))
                              (n 0))
                          (cond ((eql ch #\*)
                                 (if (and (>= max -1)
                                          (< (1+ max) (length locs)))
                                     (wt ","))
                                 (do ((v  (nthcdr (max 0 (1+ max)) locs) (cdr 
v)))
                                     ((null v))
                                     (wt-loc (car v))
                                     (if (cdr v) (wt ","))))
                                ((eql ch #\-)
                                 (unless (and (> (length fun) (1+ (incf i)))
                                              (eql (setq ch (char (the string 
fun) (1+ i))) #\1))
                                   (baboon))
                                 (setq max -1)
                                 (wt-fixnum-loc (cond ((eq *value-to-go* 'top) 
(list 'vs-address "base" (cdr (vs-push))))
                                                      ((and (not (eq 
*value-to-go* 'return))
                                                            (not (rassoc 
*value-to-go* +return-alist+))
                                                            (not 
*values-to-go*))
                                                       (list 'fixnum-value nil 
0))
                                                      (*mv-var*
                                                       (cond ((>= 
(var-known-init *mv-var*) 0)
                                                              (setq 
*values-to-go* 
                                                                    (nthcdr 
(var-known-init *mv-var*) *values-to-go*)))
                                                             (t
                                                              (unless (boundp 
'*extend-vs-top*) (baboon))
                                                              (setq 
*extend-vs-top* t *values-to-go* nil)))
                                                       (list 'var *mv-var* nil))
                                                      ((list 'vs-address "base" 
(cdr (vs-push)))))))
                                 ((digit-char-p ch 10)
                                  (setq n (- (char-code ch)
                                             (char-code #\0)))
                                  (when (and
                                         (> (length fun) (+ i 2))
                                         (progn (setq ch (char (the string fun) 
(+ i 2)))
                                                (digit-char-p ch)))
                                    (setq n (+ (* n 10)
                                               (- (char-code ch)
                                                  (char-code #\0))))
                                    (incf i))
                                  (cond ((>= n max) (setq  max n)))
                                  (wt-loc (nth n locs)))))
                          (incf i 2))
                        ((char= char #\@);FIXME better error checking
                         (let* ((n (- (char-code (char fun (1+ i))) 
#.(char-code #\1)))
                                (n (if (digit-char-p (char fun (+ i 2))) 
                                       (+ (* 10 (1+ n)) (- (char-code (char fun 
(1+ (incf i)))) #.(char-code #\1))) n))
                                (pos (position #\@ fun :start (+ i 2)))
                                (new-fun (subseq fun (+ i 2) pos))
                                (*value-to-go* (or (nth n *values-to-go*)
                                                   (and (member *value-to-go* 
'(top return))
                                                        (list 'vs (vs-push)))
                                                   'trash))
                                (*values-to-go* nil))
                           (set-loc (list (nth n others) (flags) new-fun locs))
                           (setf maxv (max maxv (1+ n)))
                           (setf i (1+ pos))))
                        (t
                         (princ char *compiler-output1*)
                         (incf i)))))
           (setq *values-to-go* (nthcdr maxv *values-to-go*)))
          ((values (apply fun locs))))))

=============================================================================
-- 
Camm Maguire                                        address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah