;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 121.3
;;; Reason:
;;;  Compiler optimizers:
;;;   Add *TRACE-OPTIMIZATIONS*, *RECORD-OPTIMIZATIONS*.
;;;   Add type-based optimizers (ADD-TYPED-OPTIMIZER, DEFINE-TYPED-OPTIMIZER).
;;;   Open code LISP:MAP for all-list list-or-null result cases.
;;;   LISP:SOME and LISP:EVERY turn into Zetalisp forms for single-list
;;;    case.
;;; Written 5-Jan-87 17:13:48 by rg at site LMI Cambridge
;;; while running on Curley from band 2
;;; with Experimental System 121.2, Experimental Lambda-Diag 15.0, Experimental ZMail 70.0, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, Experimental TCP-Kernel 41.0, Experimental TCP-User 64.0, Experimental TCP-Server 47.0, microcode 1730, SDU Boot Tape 3.14, SDU ROM 103.



; From file DJ: L.SYS; QCP1.LISP#676 at 5-Jan-87 17:13:49
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "


(defvar *trace-optimizations* nil
  "If T, report all optimizations.
If a list, only report the named optimizations.
Reports go to *TRACE-OUTPUT*")

(defvar *trace-optimizations-print-level* 4)
(defvar *trace-optimizations-print-pretty* t)

(defvar *record-optimizations* nil
  "If T, meter all optimizations.
If a list, only meter the named optimizations.")

(defvar *optimizer-usage* '())

(defstruct (optimizer-usage (:type list)
			    (:alterant nil)
			    (:conc-name opt-usage-))
  name
  count
  function-uses)

(defsubst optimizer-usage-entry (optimizer)
  (assq optimizer *optimizer-usage*))

(defun optimizer-usage-count (optimizer)
  (let ((entry (optimizer-usage-entry optimizer)))
    (if entry (opt-usage-count entry) 0)))

(defun optimizer-function-usage (optimizer)
  (let ((entry (optimizer-usage-entry optimizer)))
    (and entry (opt-usage-function-uses entry))))

(defun invoke-optimizer (optimizer form)
  (flet ((applicable-p (switch)
	   (and switch (or (eq switch t) (memq optimizer switch)))))
    (let ((new (funcall optimizer form)))
      (unless (eq new form)
	(when (applicable-p *trace-optimizations*)
	  (let ((*print-pretty* *trace-optimizations-print-pretty*)
		(*print-level* *trace-optimizations-print-level*))
	    (format *trace-output* "~&~S ~optimized ~S~%into ~S~~%" optimizer form new)))
	(when (applicable-p *record-optimizations*)
	  (let ((entry (optimizer-usage-entry optimizer)))
	    (cond (entry
		   (pushnew name-to-give-function (opt-usage-function-uses entry) :test #'equal)
		   (incf (opt-usage-count entry)))
		  (t
		   (push (make-optimizer-usage :name optimizer :count 1
					       :function-uses (list name-to-give-function))
			 *optimizer-usage*))))))
      new)))

;; Copied from LAD: RELEASE-3.SYS; QCP1.LISP#663 on 3-Oct-86 14:36:04
;;; Given a form, apply optimizations and expand macros until no more is possible
;;; (at the top level).  Also apply style-checkers to the supplied input
;;; but not to generated output.  This function is also in charge of checking for
;;; too few or too many arguments so that this happens before optimizers are applied.
;;;  dont-optimize means not to run optimzers for the top-level form
;;;  this does not affect the mandatory calling of rewriters for the form
(defun compiler-optimize (form &optional dont-optimize
			  &aux (*check-style-p* *check-style-p*))
  (if (already-optimized-p form)
      form
    (do (tem fn local-definition rewritten-already)
	((atom form))				;Do until no more expansions possible
      (setq fn (lambda-macro-expand (car form)))
      (unless (eq fn (car form)) (setq form (cons fn (cdr form))))
      (unless rewritten-already
	;; Check for too few or too many arguments
	(check-number-of-args form fn))
      (setq local-definition
	    (and (symbolp fn) (fsymeval-in-function-environment fn *function-environment*)))
      ;; Do style checking
      (and (not rewritten-already)
	   (not local-definition)
	   (symbolp fn)
	   *check-style-p*
	   (not inhibit-style-warnings-switch)
	   (setq tem (get fn 'style-checker))
	   (funcall tem form))
      ;; Optimize args to vanilla functions
      (when (symbolp fn)
	;; don't optimize args to macros of special forms, or to frobs with p1 handlers
	(unless (if local-definition
		    (eq (car local-definition) 'macro)
		  (or (get fn 'p1)
		      (macro-function fn)
		      (special-form-p fn)))
	  (setq form (cons (car form)
			   (let ((*p1value* 1)) ; Need one value from each argform
			     (mapcar #'compiler-optimize (cdr form)))))))
      (or (unless (or local-definition (not (symbolp fn)))
	    (dolist (opt (get fn 'rewriters))
	      (unless (eq form (setq form (funcall opt form)))
		;; Rewriter changed something, don't do macros this pass
		(setq rewritten-already t)
		(return t))))
	  (unless (or local-definition
		      (not (symbolp fn))
		      dont-optimize
		      *inhibit-optimizers*)
	    (dolist (opt (get fn 'optimizers))
	      (unless (eq form (setq form (invoke-optimizer opt form)))
		;; Optimizer changed something, don't do macros this pass
		(setq rewritten-already t)
		(return t))))
	  ;; No optimizer did anything => try expanding macros.
	  (warn-on-errors ('macro-expansion-error "Error expanding macro ~S:" fn)
	    ;; This LET returns T if we expand something.
	    (or (let ((record-macros-expanded t))
		  (multiple-value-setq (form tem)
		    (compiler-macroexpand-1 form))
		  tem)				;non-nil if macroexpansion happened
		;; Stop looping, no expansions apply
		(return nil)))
	  ;; The body of the WARN-ON-ERRORS either does RETURN or returns T.
	  ;; So if we get here, there was an error inside it.
	  (return (setq form `(error-macro-expanding ',form))))
      ;; Only do style checking the first time around
      (setq *check-style-p* nil))
    ;; Result is FORM
    (flag-already-optimized form)))

))

; From modified file DJ: L.SYS; QCP1.LISP#676 at 5-Jan-87 17:54:56
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "


(defun find-variable-home (variable-name)
  "Return a home for the lexical variable named VARIABLE-NAME.
Only currently visible variables are considered."
  (find variable-name (the list *vars*) :key #'var-name))

(defun get-var-declaration (var-home declaration)
  (getf (var-declarations var-home) declaration))

))

; From modified file DJ: L.SYS; QCOPT.LISP#174 at 5-Jan-87 17:57:31
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


;;; This really can't do much in the Lambda compiler -- or can it ?
(defun expression-typep (expression type)
  (declare (values typep knownp))
  (condition-case (error)
      (cond ((constantp expression)
	     (values (typep (eval expression) type) t))
	    ;; A variable
	    ((symbolp expression)
	     (if (and (get expression 'system-constant) (boundp expression))
		 (values (typep (symbol-value expression) type) t)
	       (let ((home (find-variable-home expression)))
		 (when home
		   (let ((typedecl (get-var-declaration home 'type)))
		     (when typedecl
		       (si::compilation-subtypep typedecl type)))))))
	    ;; >> General form.  Could check FTYPE and FUNCTION declarations.
	    ((and (consp expression) (eq (first expression) 'the))
	     (si::compilation-subtypep (second expression) type))
	    (t (values nil nil)))
    (si::invalid-type-specifier (values nil nil))
    (error (warn 'bad-type-usage :probable-error
		 "Error while trying to check type of ~S as ~S:~%   ~A"
		 expression type (send error :report-string))
	   (values nil nil))))

(defun every-expression-typep (expressions type)
  (lisp:every #'(lambda (exp) (expression-typep exp type)) (the list expressions)))

(defun expression-subtypep (expression type)
  (declare (values subtypep knownp))
  (condition-case (error)
      (cond ((constantp expression)
	     (values (si::compilation-subtypep (eval expression) type) t))
	    ((and (symbolp expression) (get expression 'system-constant) (boundp expression))
	     (values (si::compilation-subtypep (symbol-value expression) type) t))
	    (t (values nil nil)))
    (si::invalid-type-specifier (values nil nil))
    (error (warn 'bad-type-usages :probable-error
		 "Error while trying to check subtype of ~S as ~S:~%   ~A"
		 expression type (send error :report-string))
	   (values nil nil))))

(defun every-expression-subtypep (types type)
  (lisp:every #'(lambda (typ) (expression-subtypep typ type)) (the list types)))

(defun expression-type-equal (expression type)
  (flet ((type-equal (t0 t1)
	   (or (equal t0 t1)
	       (and (si::compilation-subtypep t0 t1) (si::compilation-subtypep t1 t0)))))
    (condition-case (error)
	(values
	 (cond ((constantp expression)
		(type-equal (eval expression) type))
	       ((and (symbolp expression) (get expression 'system-constant) (boundp expression))
		(type-equal (symbol-value expression) type) t)))
    (si::invalid-type-specifier nil)
    (error (warn 'bad-type-usages :probable-error
		 "Error while trying to check type equivalance of ~S and ~S:~%   ~A"
		 expression type (send error :report-string))
	   nil))))

(defun every-expression-type-equal (types type)
  (lisp:every #'(lambda (typ) (expression-type-equal typ type)) (the list types)))

(defun make-expression-match-check (after-rest-p param)
  (let ((type (second param)))
    (or (when (consp type)
	  (case (first type)
	    (:subtype
	     `(,(if after-rest-p 'every-expression-subtypep 'expression-subtypep)
	       ,(first param) ',(second type)))
	    (:supertype
	     `(,(if after-rest-p 'every-expression-subtypep 'expression-subtypep)
	       ',(second type) ,(first param)))
	    (:type
	     `(,(if after-rest-p 'every-expression-type-equal 'expression-type-equal)
	       ,(first param) ',(second type)))
	     ))
	`(,(if after-rest-p 'every-expression-typep 'expression-typep)
	  ,(first param) ',(second param)))))

;;; Parameters for matching argument types:
;;; IGNORE -- ignore
;;; symbol -- Parameter, matches any type
;;; (symbol type [optional-default] [optional-supplied-p]) -- match a variable of a type,
;;;  optional frobs legal after &OPTIONAL.
;;; Understood keywords: &OPTIONAL, &KEY, &REST, &ALLOW-OTHER-KEYS, &WHOLE
;;; The optional-default form should itself return a FORM.
;;; For the &REST argument, ALL expressions must of the specified type
;;; Special ``type specifiers'':
;;; (:SUBTYPE type-specifier): Useful when the parameter itself gets a type specifier;
;;;  matches when it's (SI::COMPILATION-)SUBTYPEP the type specifier.
;;; (:SUPERTYPE type-specifier): Matches when the type-specifier is SUBTYPEP the parameter.
;;; As a special case, if the last parameter is &REST, a match will occur only if no
;;; other arguments were passed.
(defun typed-optimizer-function (parameters body)
  (declare (values lambda-list form doc))
  (multiple-value-bind (body decls doc) (extract-declarations body '((sys:downward-function)) t)
    (do* ((params parameters (cdr params))
	  (param (car params) (car params))
	  (whole '.form.)
	  allow-optional-vars after-rest-p
	  lambda-list
	  checks)
	 ((null params) (values (list whole)
				`(apply #'(lambda ,(nreverse lambda-list)
					    (declare ,@decls)
					    (if (and ,@checks) (progn ,@body) ,whole))
					(cdr ,whole))
				doc))
      (macrolet ((collect (x) `(push ,x lambda-list)))
	(case param
	  ((&optional &key)
	   (collect param)
	   (setq allow-optional-vars t after-rest-p nil))
	  (&allow-other-keys
	   (collect param)
	   (setq allow-optional-vars nil))
	  (&rest
	   (collect param)
	   (unless (cdr params) ;; check for &REST at end
	     (collect '.others.)
	     (push '(null .others.) checks))
	   (setq allow-optional-vars nil after-rest-p t))
	  (&whole
	   (pop params)
	   (setq whole (car params)))
	  (otherwise
	   (etypecase param
	     ((and symbol (not null))
	      (if (lisp:member param lambda-list-keywords)
		  (error "Unknown lambda list keyword ~S" param)
		(collect param)))
	     (cons
	      (push (make-expression-match-check after-rest-p param)
		    checks)
	      (collect (if (and allow-optional-vars (cddr param))
			   (cons (first param) (cddr param))
			 (first param)))))
	   (setq after-rest-p nil)))))))

(defmacro define-typed-optimizer (name parameters &body body)
  "Define a function which will either return a new form, or the old one.
PARAMETERS is like a lambda-list for matching the types of arguments.
Each element can be:
a symbol -- an argument of any type
/(symbol type default supplied-p) -- matches the symbol with an expression
 of known type.  The second two elements are used with parameters that can
 be optional (after &OPTIONAL and &KEY).
A &REST parameter matches when every expression matches.  If &REST is the
 last element of the parameter list, more arguments are allowed in the
 original form, but they never match.  This is useful when optimizing a
 function for getting just one (or no) rest arguments.
&ALLOW-OTHER-KEYS is allowed; &WHOLE is also allowed.

If the parameters match, BODY computes the optimized form.  If it turns that
that the form cannot be optimized even with the match, the original form should
be returned by using the &WHOLE parameter.

Somes special ``type'' specifiers are accepted: (:SUBTYPE x).  This matches if the
parameter itself is a type specifier (known at compile time), and it is a
subtype of x.  (:SUPERTYPE x) matches when x is a subtype of the parameter.
(:TYPE x) x and the parameter are type-equivalent."
  (multiple-value-bind (opt-lambda-list opt-form) (typed-optimizer-function parameters body)
    `(defun ,name ,opt-lambda-list ,opt-form)))

(defmacro add-typed-optimizer (function optimizer-name &optional parameters &body body)
  "Install a type-based optimizer for FUNCTION.
Either OPTIMIZER-NAME has been defined with DEFINE-TYPED-OPTIMIZER, or the
parameters and body are supplied to define it.  See DEFINE-TYPED-OPTIMIZER for
detail on matching types."
  `(progn
     ,(when parameters
	`(define-typed-optimizer ,optimizer-name ,parameters ,@body))
     (add-optimizer-internal ',function ',optimizer-name)))

))

; From modified file DJ: L.SYS; QCOPT.LISP#174 at 5-Jan-87 17:58:08
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "

(defoptimizer make-sequence-known-type make-sequence (form)
  (let ((type-form (second form)))
    (if (constantp type-form)
	(let ((type (eval type-form)))
	  (cond ((eq type 'list)
		 `(make-list ,@(cddr form)))
		((memq type '(string simple-string))
		 `(make-string ,@(cddr form)))
		((ignore-errors  (si::compilation-subtypep type 'vector))
		 (let ((atype (si::type-canonicalize type nil nil)))
		   `(cli:make-array ,(third form)
				    :element-type ',(if (eq (second atype) '*)
							t
						      (second atype))
				    ,@(cdddr form))))
		(t form)))
      form)))

))

; From modified file DJ: L.SYS; QCOPT.LISP#174 at 5-Jan-87 18:01:44
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(add-typed-optimizer cli:map list-lisp-map->mapcar
		     ((result-type (:type list)) function &rest (sequences list))
  `(mapcar ,function ,@sequences))

(add-typed-optimizer cli:map list-lisp-map->mapc
		     ((result-type (member nil)) function &rest (sequences list))
  `(progn (mapc ,function ,@sequences) nil))

))

; From modified file DJ: L.SYS; QCOPT.LISP#174 at 5-Jan-87 19:03:50
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(define-typed-optimizer use-zl-list-predicate-checker (&whole form predicate (sequence list) &rest)
  `(,(cdr (assq (car form) '((cli:every . zl:every) (cli:some . zl:some))))
    ,sequence ,predicate))

(add-typed-optimizer cli:every use-zl-list-predicate-checker)
(add-typed-optimizer cli:some use-zl-list-predicate-checker)

))