(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED "18-Oct-93 17:19:21" "{Pele:mv:envos}Sources>CLTL2>XCLC-OPTIMIZERS.;2" 18825 IL:|previous| IL:|date:| " 4-Feb-92 10:31:17" "{Pele:mv:envos}Sources>CLTL2>XCLC-OPTIMIZERS.;1") ; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 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 LOAD-TIME-VALUE) (IL:SPECIAL-FORMS LOAD-TIME-VALUE) (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 (LISP::X) `(CAR (CAR (CAR (CAR ,LISP::X))))) (DEFOPTIMIZER CAAADR (LISP::X) `(CAR (CAR (CAR (CDR ,LISP::X))))) (DEFOPTIMIZER CAAAR (LISP::X) `(CAR (CAR (CAR ,LISP::X)))) (DEFOPTIMIZER CAADAR (LISP::X) `(CAR (CAR (CDR (CAR ,LISP::X))))) (DEFOPTIMIZER CAADDR (LISP::X) `(CAR (CAR (CDR (CDR ,LISP::X))))) (DEFOPTIMIZER CAADR (LISP::X) `(CAR (CAR (CDR ,LISP::X)))) (DEFOPTIMIZER CAAR (LISP::X) `(CAR (CAR ,LISP::X))) (DEFOPTIMIZER CADAAR (LISP::X) `(CAR (CDR (CAR (CAR ,LISP::X))))) (DEFOPTIMIZER CADADR (LISP::X) `(CAR (CDR (CAR (CDR ,LISP::X))))) (DEFOPTIMIZER CADAR (LISP::X) `(CAR (CDR (CAR ,LISP::X)))) (DEFOPTIMIZER CADDAR (LISP::X) `(CAR (CDR (CDR (CAR ,LISP::X))))) (DEFOPTIMIZER CADDDR (LISP::X) `(CAR (CDR (CDR (CDR ,LISP::X))))) (DEFOPTIMIZER CADDR (LISP::X) `(CAR (CDR (CDR ,LISP::X)))) (DEFOPTIMIZER CADR (LISP::X) `(CAR (CDR ,LISP::X))) (DEFOPTIMIZER CDAAAR (LISP::X) `(CDR (CAR (CAR (CAR ,LISP::X))))) (DEFOPTIMIZER CDAADR (LISP::X) `(CDR (CAR (CAR (CDR ,LISP::X))))) (DEFOPTIMIZER CDAAR (LISP::X) `(CDR (CAR (CAR ,LISP::X)))) (DEFOPTIMIZER CDADAR (LISP::X) `(CDR (CAR (CDR (CAR ,LISP::X))))) (DEFOPTIMIZER CDADDR (LISP::X) `(CDR (CAR (CDR (CDR ,LISP::X))))) (DEFOPTIMIZER CDADR (LISP::X) `(CDR (CAR (CDR ,LISP::X)))) (DEFOPTIMIZER CDAR (LISP::X) `(CDR (CAR ,LISP::X))) (DEFOPTIMIZER CDDAAR (LISP::X) `(CDR (CDR (CAR (CAR ,LISP::X))))) (DEFOPTIMIZER CDDADR (LISP::X) `(CDR (CDR (CAR (CDR ,LISP::X))))) (DEFOPTIMIZER CDDAR (LISP::X) `(CDR (CDR (CAR ,LISP::X)))) (DEFOPTIMIZER CDDDAR (LISP::X) `(CDR (CDR (CDR (CAR ,LISP::X))))) (DEFOPTIMIZER CDDDDR (LISP::X) `(CDR (CDR (CDR (CDR ,LISP::X))))) (DEFOPTIMIZER CDDDR (LISP::X) `(CDR (CDR (CDR ,LISP::X)))) (DEFOPTIMIZER CDDR (LISP::X) `(CDR (CDR ,LISP::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 LISP::ARGS &CONTEXT LISP::CTXT) (COND ((AND LISP::ARGS (NULL (CDR LISP::ARGS))) (IL:* IL:\; "Throw away extra values.") `((IL:OPCODES IL:NOP) ,(CAR LISP::ARGS))) (*NEW-COMPILER-IS-EXPANDING* (CASE (CONTEXT-VALUES-USED LISP::CTXT) ((0) `(PROGN ,@LISP::ARGS)) ((1) `(PROG1 ,@LISP::ARGS)) (OTHERWISE `(IL:MISCN VALUES ,@LISP::ARGS)))) (T `(IL:MISCN VALUES ,@LISP::ARGS)))) (DEFOPTIMIZER VALUES-LIST (LISP::ARG &CONTEXT LISP::CTXT) (IF *NEW-COMPILER-IS-EXPANDING* (CASE (CONTEXT-VALUES-USED LISP::CTXT) ((0) LISP::ARG) ((1) `(CAR ,LISP::ARG)) (OTHERWISE `(IL:MISCN VALUES-LIST ,LISP::ARG))) `(IL:MISCN VALUES-LIST ,LISP::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 LOAD-TIME-VALUE (LISP::FORM &OPTIONAL LISP::READ-ONLY-P) (IL:* IL:|;;|  "Copied from IL:LOADTIMECONSTANT; they're the same thing to the PavCompiler, I believe...") (IF *NEW-COMPILER-IS-EXPANDING* (MAKE-EVAL-WHEN-LOAD :FORM LISP::FORM) (LIST 'QUOTE (CONS IL:LOADTIMECONSTANTMARKER LISP::FORM)))) (DEFINE-SPECIAL-FORM LOAD-TIME-VALUE (LISP::FORM &OPTIONAL LISP::READ-ONLY-P) (EVAL LISP::FORM NIL)) (DEFOPTIMIZER EQ (LISP::ONE LISP::TWO) (COND ((AND (CONSTANTP LISP::ONE) (NULL (EVAL LISP::ONE))) `(NULL ,LISP::TWO)) ((AND (CONSTANTP LISP::TWO) (NULL (EVAL LISP::TWO))) `(NULL ,LISP::ONE)) (T 'PASS))) (DEFOPTIMIZER EQL (&WHOLE LISP::FORM) (OPTIMIZE-EQL LISP::FORM)) (DEFOPTIMIZER IL:EQP (&WHOLE IL:FORM) (OPTIMIZE-EQUALITY IL:FORM)) (DEFOPTIMIZER EQUAL (&WHOLE LISP::FORM) (OPTIMIZE-EQUALITY LISP::FORM)) (DEFOPTIMIZER IL:EQUAL (&WHOLE IL:FORM) (OPTIMIZE-EQUALITY IL:FORM)) (DEFOPTIMIZER EQUALP (&WHOLE LISP::FORM) (OPTIMIZE-EQUALITY LISP::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 1991 1992 1993)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP