;;; -*- Mode:LISP; Package:META-EVAL; Base:8 -*-


;;; I got the name PROGITOR from RG 9/02/84 14:39:25 -gjc
;;; This source->source transformation stuff has some demand amoung meta-lisp
;;; hackers such as Gary Drescher (QLOGO message passing stuff) and
;;; Mats Carlson (LM PROLOG). Mats has his own version of progitor called DEFUNN.
;;; Which isn't semantically correct but he uses it anyway. He could better switch
;;; to this. The primary motivating force to putting this into the default system
;;; was to make it available for running the RPG benchmarks of lisp.

;;; the only way now to turn on "things" on a per-file basis is with
;;; file mode-lines. So we define a new mode.

(defconst *source-optimizations* nil)

;; khs didn't like the name "source-optimizations" so I've changed it to
;; source->source-optimizations which is what it really is.

(defprop :source-optimizations source->source-file-switch fs:file-attribute-bindings)
(defprop :source->source-optimizations source->source-file-switch fs:file-attribute-bindings)

(defun source->source-file-switch (file key value) file key
  (values (list '*source-optimizations*)
	  ;; as I recall, somebody will rplacd our return values someplace, so we beware -gjc.
	  (list (optimization-name-eval value))))


(defprop :t  (:progitor :argument-reduction) optimization-name-value)
(defprop :ucode (:t :map-open-coding :cons-MAPCAR :FANCY-MAPCAR) optimization-name-value)

(defun optimization-name-eval-map (l)
  (lexpr-funcall #'union () (mapcar #'optimization-name-eval l)))

(defun optimization-name-eval (x)
  (cond ((symbolp x)
	 (cond ((get x 'optimization-name-value)
		(optimization-name-eval-map (get x 'optimization-name-value)))
	       ((missing-optimization-property? x)
		(ferror 'fs:invalid-file-attribute
			"unknown optimization name: ~S" x))
	       (t (list x))))
	((listp x)
	 (optimization-name-eval-map x))
	(t
	 (ferror 'fs:invalid-file-attribute
		 "Bad form of optimization spec: ~S" x))))

(defun vanilla-arglist? (l)
  (or (null l)
      (and (listp l)
	   (do ((l l (cdr l)))
	       ((null l) t)
	     (and (memq (car l) lambda-list-keywords)
		  (return nil))))))

(defun source-optimizations-qc-translate-function-hook (fspec exp)
  ;; (named-lambda name argl . body)
  (cond ((and *source-optimizations*
	      (or (symbolp fspec) (and (listp fspec)
				       (eq ':property (Car fspec))))
	      (eq (car exp) 'named-lambda)
	      (vanilla-arglist? (caddr exp)))
	 (let ((*source-optimizations* (if (listp fspec)
					   (remq :progitor *source-optimizations*)
					 *source-optimizations*)))
	   (attempt-progitor-source-optimization fspec exp)))
	(t exp)))

(defconst *progitor-catch-error? t)
(defconst *progitor-result-trace? nil)

(defmacro defprogy (name arglist &body body)
  "Use defprogy to test the progitor"
  (let ((*progitor-catch-error? nil)
	(*progitor-result-trace? t)
	(*source-optimizations* (optimization-name-eval :t)))
    (select-match (attempt-progitor-source-optimization
			  name `(named-lambda ,name ,arglist (block ,name . ,body)))
      (`(named-lambda ,name ,arglist (block ,ignore . ,body))
       t
       `(defun ,name ,arglist . ,body))
      (otherwise "internal inconsistency lossage"))))

;; generalize things to hack other optimizations in the future.
;; This will entail organizing a set of HOOKS and HOOK-STATES in the meta-eval,
;; allowing things to trigger. Probably a two-pass is called for, first pass
;; allows things to detect of optimizations will win, gathering information,
;; then second pass allows extra-code to be wrapped on various places,
;; (e.g. here in progitor we introduce an outer tagbody/block form),
;; while the hooks are run again to expand into what they want to expand into.
;; Common-subexpression optimizations fit into this model.
;; We also want to attack a more subtle optimization, the detection of
;; possible interation, examples:
;; (defun fact (x) (if (zerop x) 1 (times x (fact (sub1 x)))))
;; (defun foo (l) (if (null l) nil (cons (bar (car l)) (foo (cdr l)))))
;; ==>
;; maybe that is asking too much, or perhaps too little.
;; a more pattern-match driven meta-eval could be called for here.
;; on each recursion we match a pattern of both CONTEXT (e.g. *META-TARGET*)
;; and FORM. 
;; Also, common-sub-expression optimizations must deal with wrapping code
;; in the form of LET's at various contontours. So we would have
;; (defun meta-eval-sub (...) (enclose-wrappers-from-below ... do what you did before...))
;; If the wrappers would indicate further optimization then we get a hairy inefficient
;; multiple-try-until-nothing style things. My taste is to restrict what you can
;; wrap.
;; Another thing we could put into this pass: type-propagation and type-specific
;; code generation. meta-eval-sub then returns two values, form and <type>.

(defun attempt-progitor-source-optimization (fspec exp)
  (format t "~&Attempting ~S optimizations on ~S" *source-optimizations* fspec)
  ;; (named-lambda foo argl (block foo . body))
  ;; we want to extract the body inside the block as our actually body.
  ;; the strange use of prog here is because select-match is somewhat broken.
  (PROG ()
	(SELECT-MATCH EXP
	  (`(named-lambda ,name ,argl (block ,bname . ,body))
	   (eq name bname)
	   (RETURN
	     (multiple-value-bind (name argl new-form)
		 (progitor-source-optimization-doit fspec argl body)
	       (if name
		   `(named-lambda ,name ,argl (block ,bname ,@new-form))
		 exp)))))
	(SELECT-MATCH EXP
	  (`(named-lambda ,name ,argl . ,body)
	   t
	   (RETURN (multiple-value-bind (stuff argl new-form)
		       (progitor-source-optimization-doit fspec argl body)
		     (if stuff
			 `(named-lambda ,name ,argl ,@new-form)
		       exp)))))
	(format t "Didn't match known defun form: ~S no optimizations." fspec)
	(RETURN exp)))

(defun progitor-source-optimization-doit (fspec argl body)
  (let ((def-form `(defun ,fspec ,argl ,@body)))
    (let (new-form n)
      (if *progitor-catch-error?
	  (catch-error (multiple-value (new-form n) (extended-progitor def-form)) nil)
	(multiple-value (new-form n) (extended-progitor def-form)))
      (cond ((Null new-form)
	     (format t "~&Error while optimizing ~S, punting." fspec)
	     nil)
	    ((eq new-form def-form)
	     (format t "~&No optimizations found possible for ~S." fspec)
	     nil)
	    (t
	     (format t "~&Optimizations won for ~S:~%" fspec)
	     (do ((l n (cdr l)))
		 ((null l))
	       (format t "~D ~A~p~%"
		       (cdr (car l))
		       (get (Caar l) 'optimization-saying)
		       (cdr (car l))))
	     (if *progitor-result-trace? (grind-top-level new-form))
	     ;; (defun foo () . body)
	     (values fspec argl (cdddr new-form)))))))


(compiler:set-qc-translate-function-hook 'source-optimizations-qc-translate-function-hook)


;; the :progitor optimization is kind of a special case in that it
;; needs information from outside to be passed in, and it needs an
;; outside-wrapper of code. We have made provision for this sort of
;; thing, but no gaurantee of non-interaction, extensibility but
;; not transparency.

(defconst *required-optimization-properties*
	  '(optimization-match? optimization optimization-saying))


(defun missing-optimization-property? (x)
  (do ((l *required-optimization-properties* (cdr l)))
      ((null l)
       ())
    (or (get x (car l)) (return (car l)))))

(defconst *extended-progitor-trace? nil)

(defvar *variables-to-substitue*)
(defvar *values-to-substitute*)

(defun mapkan (f l)
  ;; khs broke MAPCAN, my favorite function. So I use this instead now.
  (apply #'nconc (mapcar f l)))

(defun extended-progitor (a-defun &aux *variables-to-substitue* *values-to-substitute*)
  (let ((optimizations (mapkan #'(lambda (x)
				   (let ((missing? (missing-optimization-property? x)))
				     (cond ((null missing?)
					    (list (cons x 0)))
					   (t
					    (format t "~&~S optimization lacks the ~S property~%"
						    x missing?)
					    nil))))
			       *source-optimizations*))
	(body `(progn ,@(cdddr a-defun))))
    (let ((v (apply #'append
		    (mapcar #'(lambda (o)
				(if (Get (car o) 'optimization-outer-values-compute)
				    (funcall (Get (car o) 'optimization-outer-values-compute)
					     a-defun
					     o)))
			    optimizations))))
      (progv (mapcar #'car v)
	     (mapcar #'cdr v)
	(let ((new-body (caddr (meta-eval `(lambda ,(caddr a-defun)
					     (meta-let ((*meta-target* 'ret)) ,body))
					  *variables-to-substitue*
					  *values-to-substitute*
					  #'(lambda (form)
					      (when *extended-progitor-trace?
						(format t "~&~A: ~S"
							*meta-target* form))
					      (do ((l optimizations (cdr l)))
						  ((null l) form)
						(when (funcall (get (caar l)
								    'optimization-match?)
							       form)
						  (when *extended-progitor-trace?
						    (format t " winner: ~S" (caar l)))
						  (setf (cdar l) (1+ (cdar l)))
						  (return (funcall (get (caar l)
									'optimization)
								   form)))))))))
	  (cond ((zerop (apply #'+ (mapcar #'cdr optimizations)))
		 a-defun)
		('else
		 (do ((l optimizations (cdr l)))
		     ((null l))
		   (if (and (not (zerop (cdar l)))
			    (get (caar l) 'optimization-outer-wrap))
		       (setq new-body (funcall (get (caar l) 'optimization-outer-wrap)
					       new-body))))
		 (values `(defun ,(cadr a-defun) ,(caddr a-defun) ,new-body)
			 optimizations))))))))


;; progitor optimization:

(defprop :progitor "tail recursion" optimization-saying)

(defun (:progitor optimization-outer-wrap) (body)
  `(tagbody
    loop
       (block ,*progitor-tail-escape*
	 (return-from ,*progitor-function* ,body))
       (go loop)))

(defun (:progitor optimization-outer-values-compute) (a-defun ignore)
  `((*progitor-tail-escape* . ,(intern (string-append (cadr a-defun) "-tail-escape")))
    (*progitor-function* . ,(cadr a-defun))
    (*progitor-args* . ,(caddr a-defun))))

(defun (:Progitor optimization-match?) (form)
  (and (eq *meta-target* 'ret)
       (eq (car form) *progitor-function*)
       (do ((l *meta-BIND-stack* (cdr l)))
	   ((null l) t)
	 (and (meta-var-special-p (car l)) (return nil)))))


(defun (:progitor optimization) (form)
  `(progn ,(CONS-psetq (mapcan #'list
			       *progitor-args*
			       (cdr form)))
	  (return-from ,*progitor-tail-escape*)))

;; other optimizations:
;; I'm not putting these in as regular compiler:optimizers because there are
;; cases which "for-effect" optimizations come into play.
;; e.g. (NCONC A B) for effect is clearly
;; (RPLACD (LAST A) B).

(defprop :argument-reduction "argument reduction" optimization-saying)

(remprop 'nconc 'argument-reduction)
;(defprop nconc ((2 . nconc-2)) argument-reduction)
(remprop 'append 'argument-reduction)
;(defprop append ((2 . append-2)) argument-reduction)
; MAPCAR IS NOW UCODED.
;(defprop mapcar ((2 . mapcar-2)) argument-reduction)
(defprop fancy-mapcar ((3 . fancy-mapcar-3)) argument-reduction)

(defun (:argument-reduction optimization-match?) (form)
  (let ((l (get (car form) 'argument-reduction)))
    (cond ((null l) nil)
	  ((assq (1- (length form)) l))
	  ('else
	   (format t "~&Would have liked a ~D argument version of ~S~%"
		   (1- (length form))
		   (car form))
	   nil))))

(defun (:argument-reduction optimization) (form)
  (cons (cdr (assq (1- (length form)) (get (car form) 'argument-reduction)))
	(cdr form)))

(defprop :map-open-coding "map open coding" optimization-saying)

(defprop mapcar-2 mapcar-2-expander map-expander)

(defun (:map-open-coding optimization-match?) (form)
  (and (get (car form) 'map-expander)
       (and (listp (cadr form))
	    (Memq (caadr form) '(quote function)))))

(defun (:map-open-coding optimization) (form)
  (lexpr-funcall (get (car form) 'map-expander) (cdr form)))



(defprop :cons-MAPCAR "cons-mapcar" optimization-saying)

(defun (:cons-MAPCAR optimization-match?) (form)
  ;; looking for (CONS A (MAPCAR ...))
  (and (listp (caddr form))
       (eq (car (caddr form)) 'mapcar)))

(defun (:cons-MAPCAR optimization) (form)
  `(fancy-mapcar (ncons ,(cadr form)) ,@(cdr (caddr form))))


(DEFPROP :FANCY-MAPCAR "fancy mapcar" OPTIMIZATION-SAYING)

(DEFUN (:FANCY-MAPCAR OPTIMIZATION-MATCH?) (FORM)
  (AND (EQ (CAR FORM) 'FANCY-MAPCAR-3)
       (AND (LISTP (CADDR FORM))
	    (MEMQ (CAR (CADDR FORM)) '(QUOTE FUNCTION)))))


(DEFUN (:FANCY-MAPCAR OPTIMIZATION) (FORM)
  (LET ((CELL (CADR FORM))
	(F (CADR (CADDR FORM)))
	(ARG (CADDDR FORM)))
      `(let ((RESULT ,CELL)
	     (LL ,ARG))
	     
	   (prog (P)
		 (SETQ P RESULT)
	      loop
		 (if (null LL) (return RESULT))
		 (SETF (CDR P) (SETQ P (NCONS (,F (POP LL)))))
		 (GO LOOP)))))



(defprop :cspecials "non-setq'd special variables" optimization-saying)

(defvar *cspecials-renaming*)

(defun (:cspecials optimization-outer-values-compute) (a-defun cell)
  (let ((me-vars (apply #'append
			(mapcar #'(lambda (x)
				    (if (get (meta-var-name x) 'no-setq)
					(list (list (meta-var-name x) (gensym)))))
			 (meta-eval `(lambda ,(caddr a-defun) ,@(cdddr a-defun)))))))
    (when me-vars
      (setf (cdr cell) (length me-vars))
      (setq *variables-to-substitue*
	    (append *variables-to-substitue*
		    (mapcar #'car me-vars)))
      (setq *values-to-substitute*
	    (append *values-to-substitute*
		    (mapcar #'cadr me-vars)))
      `((*cspecials-renaming* . ,me-vars)))))


(defun (:cspecials optimization-outer-wrap) (body)
  ;; this doesn't interact, semantically with the tagbody generated by :progitor.
  (print *cspecials-renaming*)
  `(let ,(mapcar #'reverse *cspecials-renaming*)
     ,body))

(defun (:cspecials optimization-match?) (form)
  form
  ())

(defun (:cspecials optimization) (form)
  (ferror nil "should never have been called on: ~S" form))