(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (il:filecreated " 4-Jun-90 14:31:10" il:|{PELE:MV:ENVOS}SOURCES>XCLC-OPTIMIZERS.;3| 18114 il:|changes| il:|to:| (il:functions optimize-logical-op-1-arg) (optimizers logior logxor logand logeqv) (il:vars il:xclc-optimizerscoms) il:|previous| il:|date:| "23-May-90 13:13:25" il:|{PELE:MV:ENVOS}SOURCES>XCLC-OPTIMIZERS.;2|) ; Copyright (c) 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. (il:prettycomprint il:xclc-optimizerscoms) (il:rpaqq il:xclc-optimizerscoms ( (il:* il:|;;;| "Compiler optimizers") (il:define-types optimizers) (il:functions optimizer-list) (il:prop il:proptype optimizer-list) (il:functions defoptimizer) (il:* il:|;;| "Random optimizers defined within the compiler.") (optimizers caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr) (optimizers (il:arg :optimized-by convert-arg-to-\\arg) (il:setarg :optimized-by convert-setarg-to-\\setarg)) (optimizers values values-list) (optimizers il:loadtimeconstant il:getd il:fgetd il:evq) (optimizers eq eql il:eqp equal il:equal equalp) (il:functions optimize-equality optimize-eql) (optimizers (multiple-value-call :optimized-by screen-mv-call) (not :optimized-by not-to-if) (null :optimized-by null-to-if)) (optimizers il:\\callme) (il:* il:|;;| "Optimizers for File Manager forms") (il:variables *input-filecoms-variable*) (optimizers il:rpaq il:rpaq? il:rpaqq il:prettycomprint il:filecreated) (il:* il:|;;| "Other Otimization") (optimizers il:\\pilotbitblt) (il:* il:|;;| "Use the proper makefile-environment") (il:prop il:makefile-environment il:xclc-optimizers) (il:* il:|;;| "Use the proper compiler.") (il:prop il:filetype il:xclc-optimizers))) (il:* il:|;;;| "Compiler optimizers") (def-define-type optimizers "Compiler optimizers") (defmacro optimizer-list (fn) `(get ,fn 'optimizer-list)) (il:putprops optimizer-list il:proptype ignore) (defdefiner (defoptimizer (:prototype (lambda (xcl::name) (if (symbolp xcl::name) `(defoptimizer ,xcl::name ("Arg list") "Body") (destructuring-bind (xcl::form-name xcl::optimized-by xcl::opt-name ) xcl::name (and (eq ':optimized-by xcl::optimized-by) (not (null xcl::opt-name)) `(defoptimizer ,xcl::form-name ,xcl::opt-name ("Arg list") "Body")))))) (:name (lambda (il:whole) (let ((il:name (second il:whole)) (il:opt-name (third il:whole))) (if (listp il:opt-name) il:name (il:* il:\;  "(defoptimizer form-name arglist . body)") `(,il:name :optimized-by ,il:opt-name) (il:* il:\;  "(defoptimizer form-name opt-name [arg-list . body])") ))))) optimizers (il:name il:opt-name &rest il:arglist-body &environment il:env) (cond ((not il:arglist-body) (il:* il:\;  "(defoptimizer name optfn)") `(eval-when (eval compile load) (pushnew ',il:opt-name (optimizer-list ',il:name)))) (t (let* ((il:arg-list il:opt-name) (il:opt-fn-name (il:|if| (listp il:opt-name) il:|then| (il:* il:\;  "(defoptimizer form-name arglist . body)") (pack (list "optimize-" il:name) (symbol-package il:name)) il:|else| (il:* il:\;  "(defoptimizer form-name opt-name arglist . body)") (il:setq il:arg-list (il:pop il:arglist-body)) il:opt-name))) (multiple-value-bind (il:body il:decls il:doc) (il:parse-defmacro il:arg-list 'il:$$whole il:arglist-body il:name il:env :environment 'il:$$env :context 'il:$$ctx) `(eval-when (eval compile load) (setf (symbol-function ',il:opt-fn-name) #'(lambda (il:$$whole il:$$env il:$$ctx) ,@il:decls (block ,il:opt-fn-name ,il:body))) (pushnew ',il:opt-fn-name (optimizer-list ',il:name)))))))) (il:* il:|;;| "Random optimizers defined within the compiler.") (defoptimizer caaaar (cl::x) `(car (car (car (car ,cl::x))))) (defoptimizer caaadr (cl::x) `(car (car (car (cdr ,cl::x))))) (defoptimizer caaar (cl::x) `(car (car (car ,cl::x)))) (defoptimizer caadar (cl::x) `(car (car (cdr (car ,cl::x))))) (defoptimizer caaddr (cl::x) `(car (car (cdr (cdr ,cl::x))))) (defoptimizer caadr (cl::x) `(car (car (cdr ,cl::x)))) (defoptimizer caar (cl::x) `(car (car ,cl::x))) (defoptimizer cadaar (cl::x) `(car (cdr (car (car ,cl::x))))) (defoptimizer cadadr (cl::x) `(car (cdr (car (cdr ,cl::x))))) (defoptimizer cadar (cl::x) `(car (cdr (car ,cl::x)))) (defoptimizer caddar (cl::x) `(car (cdr (cdr (car ,cl::x))))) (defoptimizer cadddr (cl::x) `(car (cdr (cdr (cdr ,cl::x))))) (defoptimizer caddr (cl::x) `(car (cdr (cdr ,cl::x)))) (defoptimizer cadr (cl::x) `(car (cdr ,cl::x))) (defoptimizer cdaaar (cl::x) `(cdr (car (car (car ,cl::x))))) (defoptimizer cdaadr (cl::x) `(cdr (car (car (cdr ,cl::x))))) (defoptimizer cdaar (cl::x) `(cdr (car (car ,cl::x)))) (defoptimizer cdadar (cl::x) `(cdr (car (cdr (car ,cl::x))))) (defoptimizer cdaddr (cl::x) `(cdr (car (cdr (cdr ,cl::x))))) (defoptimizer cdadr (cl::x) `(cdr (car (cdr ,cl::x)))) (defoptimizer cdar (cl::x) `(cdr (car ,cl::x))) (defoptimizer cddaar (cl::x) `(cdr (cdr (car (car ,cl::x))))) (defoptimizer cddadr (cl::x) `(cdr (cdr (car (cdr ,cl::x))))) (defoptimizer cddar (cl::x) `(cdr (cdr (car ,cl::x)))) (defoptimizer cdddar (cl::x) `(cdr (cdr (cdr (car ,cl::x))))) (defoptimizer cddddr (cl::x) `(cdr (cdr (cdr (cdr ,cl::x))))) (defoptimizer cdddr (cl::x) `(cdr (cdr (cdr ,cl::x)))) (defoptimizer cddr (cl::x) `(cdr (cdr ,cl::x))) (defoptimizer il:arg convert-arg-to-\\arg (name expr) (if *new-compiler-is-expanding* `(il:\\arg ',name ,expr) 'pass)) (defoptimizer il:setarg convert-setarg-to-\\setarg (name expr new-value) (if *new-compiler-is-expanding* `(il:\\setarg ',name ,expr ,new-value) 'pass)) (defoptimizer values (&rest cl::args &context cl::ctxt) (cond ((and cl::args (null (cdr cl::args))) (il:* il:\; "Throw away extra values.") `((il:opcodes il:nop) ,(car cl::args))) (*new-compiler-is-expanding* (case (context-values-used cl::ctxt) ((0) `(progn ,@cl::args)) ((1) `(prog1 ,@cl::args)) (otherwise `(il:miscn values ,@cl::args)))) (t `(il:miscn values ,@cl::args)))) (defoptimizer values-list (cl::arg &context cl::ctxt) (if *new-compiler-is-expanding* (case (context-values-used cl::ctxt) ((0) cl::arg) ((1) `(car ,cl::arg)) (otherwise `(il:miscn values-list ,cl::arg))) `(il:miscn values-list ,cl::arg))) (defoptimizer il:loadtimeconstant (il:form) (il:* il:|;;;| "The new compiler uses an unforgable data structure to mark load-time forms. The old ByteCompiler used LOADTIMECONSTANTMARKER, a unique string.") (if *new-compiler-is-expanding* (make-eval-when-load :form il:form) (list 'quote (cons il:loadtimeconstantmarker il:form)))) (defoptimizer il:getd (il:fn &context il:ctxt) (if (context-predicate-p il:ctxt) `(il:\\definedp ,il:fn) 'pass)) (defoptimizer il:fgetd (il:fn) `(il:getd ,il:fn)) (defoptimizer il:evq (il:arg) il:arg) (defoptimizer eq (cl::one cl::two) (cond ((and (constantp cl::one) (null (eval cl::one))) `(null ,cl::two)) ((and (constantp cl::two) (null (eval cl::two))) `(null ,cl::one)) (t 'pass))) (defoptimizer eql (&whole cl::form) (optimize-eql cl::form)) (defoptimizer il:eqp (&whole il:form) (optimize-equality il:form)) (defoptimizer equal (&whole cl::form) (optimize-equality cl::form)) (defoptimizer il:equal (&whole il:form) (optimize-equality il:form)) (defoptimizer equalp (&whole cl::form) (optimize-equality cl::form)) (defun optimize-equality (form) (il:* il:|;;;| "FORM is a call on one of the equality-testing predicates EQL, IL:EQP, EQUAL, IL:EQUAL, or EQUALP. If one of the arguments is a literal symbol, then we can use EQ.") (destructuring-bind (fn one two) form (cond ((and (constantp one) (symbolp (eval one))) `(eq ,two ',(eval one))) ((and (constantp two) (symbolp (eval two))) `(eq ,one ',(eval two))) (t 'pass)))) (defun optimize-eql (form) (il:* il:|;;| "TRANSFORM to EQ if possible") (destructuring-bind (fn one two) form (let (e-one e-two) (cond ((and (constantp one) (or (symbolp (setq e-one (eval one))) (typep e-one 'fixnum))) `(eq ',e-one ,two)) ((and (constantp two) (or (symbolp (setq e-two (eval two))) (typep e-two 'fixnum))) `(eq ,one ',e-two)) (t 'pass))))) (defoptimizer multiple-value-call screen-mv-call (fn &body body) (il:* il:|;;;| "``Optimizer'' for special form MULTIPLE-VALUE-CALL - handle special case of list and let the rest turn into an APPLY") (cond ((and (equal fn '(il:function list)) (null (cdr body))) (cons 'il:\\mvlist body)) (t `(il:apply ,fn (nconc ,@(il:for f il:in body il:collect `(multiple-value-list ,f))))))) (defoptimizer not not-to-if (x) (if *new-compiler-is-expanding* `(if ,x nil t) 'pass)) (defoptimizer null null-to-if (x) (if *new-compiler-is-expanding* `(if ,x nil t) 'pass)) (defoptimizer il:\\callme (name &context ctxt) (cond ((not (eql (context-values-used ctxt) 0)) (warn "The ~S special form appeared in non-effect context." 'il:\\callme) `(progn (il:\\callme ,name) nil)) ((and (not (constantp name)) (or (atom name) (not (eq (car name) 'quote)))) (warn "The ~S special form was given an unquoted argument." 'il:\\callme) `(il:\\callme ',name)) (t 'pass))) (il:* il:|;;| "Optimizers for File Manager forms") (defvar *input-filecoms-variable* (il:* il:|;;;| "Used for communication between the optimizers on RPAQQ and PRETTYCOMPRINT so that the file coms can be eliminated from the file during compilation.") ) (defoptimizer il:rpaq (var expr &context ctxt) (if (context-top-level-p ctxt) `(locally (declare (global ,var)) (setq ,var ,expr)) 'pass)) (defoptimizer il:rpaq? (var expr &context ctxt) (if (context-top-level-p ctxt) `(locally (declare (global ,var)) (and (eq ,var 'il:nobind) (setq ,var ,expr))) 'pass)) (defoptimizer il:rpaqq (var expr &context ctxt) (if (context-top-level-p ctxt) `(locally (declare (global ,var)) (setq ,var ',expr)) 'pass)) (defoptimizer il:prettycomprint (coms-name &context ctxt) (cond ((context-top-level-p ctxt) nil) (t 'pass))) (defoptimizer il:filecreated (filedate filename &rest junk &context ctxt) (declare (ignore junk)) (if (and (context-top-level-p ctxt) filename (symbolp filename)) `(il:putprop ',(il:rootfilename filename) 'il:filedates '(,(cons filedate filename))) 'pass)) (il:* il:|;;| "Other Otimization") (defoptimizer il:\\pilotbitblt (&rest il:args) (if (and il:args (null (cdr il:args))) `(il:\\pilotbitblt ,@il:args nil) 'pass)) (il:* il:|;;| "Use the proper makefile-environment") (il:putprops il:xclc-optimizers il:makefile-environment (:readtable "XCL" :package (defpackage "COMPILER" (:use "LISP" "XCL")))) (il:* il:|;;| "Use the proper compiler.") (il:putprops il:xclc-optimizers il:filetype :compile-file) (il:putprops il:xclc-optimizers il:copyright ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop