;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                    ;;;;;
;;;     Copyright (c) 1989 by William Schelter,University of Texas     ;;;;;
;;;     All rights reserved                                            ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; See the doc/DOC file for information on emit-fn and
;; make-all-proclaims.  The basic idea is to utilize information gathered
;; by the compiler in a compile of a system of files in order to generate
;; better code on subsequent compiles of the system.  To do this a file
;; sys-proclaim.lisp should be produced.

;; Additionally cross reference information about functions in the system is
;; collected.

(in-package 'compiler)
(import 'sloop::sloop)

(defstruct fn
  name           ;; name of THIS FUNCTION
  def            ;; defun, defmacro 
  value-type     ;; If this function's body contained
                 ;; (cond ((> a 3) 7)
		 ;;	  ((> a 1) (foo)))
                 ;; then the return type of 7 is known at compile time
                 ;; and value-type would be fixnum. [see return-type]
  fun-values     ;; list of functions whose values are the values of THIS FN
                 ;; (foo) in the previous example.
  callees        ;; list of all functions called by THIS FUNCTION
  return-type    ;; Store a return-type computed from the fun-values
                 ;; and value-type field.  This computation is done later.
  arg-types      ;; non optional arg types.  
  no-emit        ;; if not nil don't emit declaration.
  macros
  )

(defvar *other-form* (make-fn))
(defvar *all-fns* nil)
(defvar *call-table* (make-hash-table))
(defvar *current-fn* nil)
(defun add-callee (fname)
  (cond ((consp fname)
	 (or (eq (car fname) 'values)
	     (add-callee (car fname))))
	((eq fname 'single-value))
	(fname (pushnew fname (fn-callees (current-fn))))))

(defun add-macro-callee (fname)
  (or
    ;; make sure the macro fname is not shadowed in the current environment.
    (sloop::sloop for v in *funs*
		  when (and (consp v) (eq (car v) fname))
		  do (return t))
    (pushnew fname (fn-macros (current-fn)))))

(defun clear-call-table ()
  (setf *current-fn* nil)
  (setq *all-fns* nil)
  (setq *other-form* (make-fn :name 'other-form))
  (clrhash *call-table*)
  (setf (gethash 'other-form *call-table*) *other-form*) 
  )

(defun emit-fn (flag) (setq *record-call-info* flag))

(defun type-or (a b)
  (if (eq b '*) '*
    (case a
      ((nil) b)
      ((t inline) t)
      ((fixnum inline-fixnum fixnum-value) (if (eq b 'fixnum) 'fixnum
					     (type-or t b)))
      (otherwise '*)
      )))

(defun current-fn ()
  (cond ((and (consp *current-form*)
	      (member (car *current-form*) '(defun defmacro))
	      (symbolp  (second *current-form*))
	      (symbol-package (second *current-form*));;don't record gensym'd
	      )
	 (cond ((and *current-fn*
		     (equal (second *current-form*)  (fn-name *current-fn*)))
		*current-fn*)
	       (t
		 (unless
		   (setq *current-fn*
			 (gethash (second *current-form*) *call-table*))
		   (setq *current-fn* (make-fn :name (second *current-form*)
					       :def (car *current-form*)))
		   (setf (gethash (second *current-form*) *call-table*)
			 *current-fn*)
		   (setq *all-fns* (cons *current-fn* *all-fns*)))
		 *current-fn*)))
	;; catch all for other top level forms
	(t *other-form*)))

(defun who-calls (f)
  (sloop for (ke val) in-table *call-table*
	 when (or (member f (fn-callees val))
		  (member f (fn-macros val)))
	 collect ke))


(defun add-value-type (x fn &aux (current-fn (current-fn)))
  (cond (fn (pushnew fn
		     (fn-fun-values current-fn) :test 'equal))
	(t
	  (setf (fn-value-type current-fn)
		(type-or (fn-value-type current-fn) x)))))


(defun get-var-types (lis)
  (sloop::sloop for v in lis collect (var-type v)))

(defun record-arg-info( lambda-list &aux (cf (current-fn)))
  (setf (fn-arg-types cf) (get-var-types (car lambda-list)))
  (when (sloop::sloop for v in (cdr lambda-list)
		      for w in '(&optional &rest &key
					   nil &allow-other-keys
					   )
		      when (and v w) do (return '*))
	(setf (fn-arg-types cf) (nconc(fn-arg-types cf) (list '*)))
	))

(defvar *depth* 0)
(defvar *called-from* nil)

(defun get-value-type (fname)
  (cond ((member fname *called-from* :test 'eq) nil)
	(t
	 (let ((tem (cons fname *called-from*)))
	   (declare (:dynamic-extent tem))
	   (let ((*called-from* tem))
	     (get-value-type1 fname))))))

(defun get-value-type1 (fname
			&aux tem (*depth* (the fixnum (+ 1 (the fixnum
								*depth* )))))
  (cond ((> (the fixnum *depth*) 100) '*)
	((setq tem (gethash fname *call-table*))
	 (or
	  (fn-return-type tem)
	  (sloop::sloop with typ = (fn-value-type tem)
		for v in (fn-fun-values tem)
		when (symbolp v)
		do (setq typ (type-or typ (get-value-type v)))
		else
		when (and (consp v) (eq (car v) 'values))
		do
		(setq typ (type-or typ (if (eql (cdr v) 1) t '*)))
		else do (error "unknown fun value ~a" v)
		finally
		;; if there is no visible return, then we can assume
		;; one value.
		(or typ (fn-value-type tem)
		    (fn-fun-values tem)
		    (setf typ t))
		(setf (fn-return-type tem) typ)
		(return typ)
		)))
	((get fname 'return-type))
	((get fname 'proclaimed-return-type))
	(t '*)))
	
(defun result-type-from-loc (x)
  (cond ((consp x)
	 (case (car x)
	   ((fixnum-value inline-fixnum) 'fixnum)
	   (var (var-type (second x)))
	   ;; eventually separate out other inlines
	   (t (cond ((and (symbolp (car x))
			  (get (car x) 'wt-loc))
		     t)
		    (t (print (list 'type '* x)) '*)))))
	((or (eq x t) (null x)) t)
	(t (print (list 'type '*2 x)) '*)))


(defun small-all-t-p (args ret)
  (and (eq ret t)
       (< (length args) 10)
       (sloop::sloop for v in args always (eq v t))))

;; Don't change return type but pretend all these are optional args.

(defun no-make-proclaims-hack ()
  (sloop::sloop for (ke val) in-table *call-table*
	 do (progn ke) (setf (fn-no-emit val) 1)))

  
(defun make-proclaims ( &optional (st *standard-output*)
				  &aux (ht (make-hash-table :test 'equal))
				  *print-length* *print-level* 
				  )
;  (require "VLFUN"
;	 (concatenate 'string si::*system-directory*
;		      "../cmpnew/lfun_list.lsp"))
  
  (print `(in-package ,(package-name *package*)) st)
  (sloop::sloop with ret with at
		for (ke val) in-table *call-table* 
		do
		(cond ((or (eql 1 (fn-no-emit val))
			   (not (eq (fn-def val) 'defun))))
		      (t (setq ret (get-value-type ke))
			 (setq at (fn-arg-types val))
			 (push ke   (gethash (list at ret)  ht)))))
  (sloop::sloop for (at fns) in-table ht
		do 
		(print
		 `(proclaim '(ftype (function ,@ at) ,@ fns))
		 st)))
		 
(defun setup-sys-proclaims()
  (or (gethash 'si::call-test *call-table*)
      (get 'si::call-test 'proclaimed-function)
      (load (concatenate 'string si::*system-directory*
			 "../lsp/sys-proclaim.lisp"))
      (no-make-proclaims-hack)
      ))

(defun make-all-proclaims (&rest files)
  (setup-sys-proclaims)
  (dolist (v files)
	  (mapcar 'load (directory v)))
  (write-sys-proclaims))

(defun write-sys-proclaims ()
  (with-open-file (st "sys-proclaim.lisp" :direction :output)
    (make-proclaims st)))

(defvar *file-table* (make-hash-table :test 'eq)) 

(defun add-fn-data (lis &aux tem file)
  (let ((file (and (setq file (si::fp-input-stream *standard-input*))
		   (truename file))))
  (dolist (v lis)
	  (cond ((eql (fn-name v) 'other-form)
		 (setf (fn-name v) (intern
				    (concatenate 'string "OTHER-FORM-"
						 (namestring file))))
		 (setf (get (fn-name v) 'other-form) t)))
	  (setf (gethash (fn-name v) *call-table*) v)
	  (if (setq tem (gethash (fn-name v) *file-table*))
	      (or (equal tem file)
		  (format t "~% Warn ~a redefined in ~a. Originally in ~a."
			  (fn-name v) file tem)))
	  (setf (gethash (fn-name v) *file-table*)
		file))))

(defun dump-fn-data (&optional (file "fn-data.lsp")
			       &aux (*package* (find-package "COMPILER"))
			       (*print-length* nil)
			       (*print-level* nil)
			       )
  (with-open-file (st file :direction :output)
    (format st "(in-package 'compiler)(init-fn)~%(~s '(" 'add-fn-data)
    (sloop::sloop for (ke val) in-table *call-table*
		  do (progn ke) (print val st))
    (princ "))" st)
    (truename st)))

(defun record-call-info (loc fname)
  (cond ((and fname (symbolp fname))
	 (add-callee fname)))
  (cond ((eq loc 'record-call-info) (return-from record-call-info nil)))
  (case *value-to-go*
    (return
      (if (eq loc 'fun-val)
	  (add-value-type nil (or fname  'unknown-values))
	(add-value-type (result-type-from-loc loc) nil)))
    (return-fixnum
      (add-value-type 'fixnum nil))
    (return-object
      (add-value-type t nil))
    
    (top  (setq *top-data* (cons fname nil))
	 ))
     )

(defun list-undefined-functions (&aux undefs)
  (sloop::sloop for (name fn) in-table *call-table*
		declare (ignore name)
		do (sloop for w in (fn-callees fn)
			  when (not (or (fboundp w)
					(gethash w *call-table*)
					(get w 'inline-always)
					(get w 'inline-unsafe)
					(get w 'other-form)
					))
			  do (pushnew w undefs)))
  undefs)		



(dolist (v '(throw coerce single-value  sort delete remove char-upcase
		   si::fset typep))
	(si::putprop v t 'return-type))

(defun init-fn () nil)

(defun list-uncalled-functions ( )
  (let* ((size (sloop::sloop for (ke v)
			     in-table *call-table* count t
			     do (progn ke v nil)))
	 (called (make-hash-table :test 'eq :size (+ 3 size))))
    (sloop::sloop for (ke fn) in-table *call-table*
		  declare (ignore ke)
		  do (sloop::sloop for w in (fn-callees fn)
				   do
				   (setf (gethash w called) t))
		  (sloop::sloop for w in (fn-macros fn)
				   do
				   (setf (gethash w called) t))
		  
		  )
    (sloop::sloop for (ke fn) in-table *call-table*
		  when(and
		       (not (gethash ke called))
		       (member (fn-def fn) '(defun defmacro)
			       :test 'eq))
		  collect ke)))

;; redefine the stub in defstruct.lsp
(defun si::record-fn (name def arg-types return-type)
  (if (null return-type) (setq return-type t))
  (and *record-call-info*
       *compiler-in-use*
       (let ((fn (make-fn :name name
		      :def def
		      :return-type return-type
		      :arg-types arg-types)))
	 (push fn *all-fns*)
	 (setf (gethash name *call-table*) fn))))

(defun get-packages (&optional (st "sys-package.lisp") pass
			       &aux (si::*print-package* t))
  (flet ((pr (x) (format st "~%~s" x)))
     (cond ((null pass)
	    (with-open-file (st st :direction :output)
	      (get-packages st 'establish)
	      (get-packages st 'export)
	      (get-packages st 'shadow)
	      (format st "~2%")
	      (return-from get-packages nil))))
	(dolist (p  (list-all-packages))
	   (unless
	    (member (package-name p)
		    '("SLOOP"
		      "COMPILER" "SYSTEM" "KEYWORD" "LISP" "USER")
		    :test 'equal
		    )
	    (format st "~2%;;; Definitions for package ~a of type ~a"
		    (package-name p) pass)
	    (ecase pass
	      (establish
	       (let ((SYSTEM::*PRINT-PACKAGE* t))
		 (pr 
		  `(in-package ,(package-name p) :use nil
			       ,@ (if (package-nicknames p)
				      `(:nicknames ',(package-nicknames p)))))))
	      (export
	       (let ((SYSTEM::*PRINT-PACKAGE* t))
		 (pr 
		  `(in-package ,(package-name p)
			       :use
			       '(,@
				 (mapcar 'package-name (package-use-list p)))
			       ,@(if (package-nicknames p)
				     `(:nicknames ',(package-nicknames p))))))
	       (let (ext (*package* p)
			 imps)
		 (do-external-symbols (sym p) (push sym ext)
				      (or (eq (symbol-package sym) p)
					  (push sym imps)))
		 (pr `(import ',imps))
		 (pr `(export ',ext))))
	      (shadow
	       (let ((SYSTEM::*PRINT-PACKAGE* t))
		 (pr `(in-package ,(package-name p))))
	       (let (in out (*package* (find-package "LISP")))
		 (dolist (v (package-shadowing-symbols p))
			 (cond ((eq (symbol-package v) p)
				(push v in))
			       (t (push v out))))
		 (pr `(shadow ',in))
		 (pr `(shadowing-import ',out))
		 (let (imp)
		   (do-symbols (v p)
			       (cond ((not (eq (symbol-package v) p))
				      (push v imp))))
		   (pr `(import ',imp))))))))))