;-*- MODE: LISP; PACKAGE: COMPILER; BASE: 8 -*- ; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ; ** (c) Copyright 1984 Lisp Machine Inc ** ; these should probably eventually go in DEFMIC (DEFPROP %DATA-TYPE DTP-FIX RESULT-DATA-TYPE) (DEFPROP M-EQ T-OR-NIL RESULT-DATA-TYPE) (DEFPROP M-= T-OR-NIL RESULT-DATA-TYPE) (DEFPROP LDB DTP-FIX RESULT-DATA-TYPE) ;**EVENTUALLY SHOULD LOOK AT BYTE-SPEC.** (DEFPROP MULTIBUS-READ-8 DTP-FIX RESULT-DATA-TYPE) (DEFPROP MULTIBUS-READ-16 DTP-FIX RESULT-DATA-TYPE) (DEFPROP TIME-DIFFERENCE DTP-FIX RESULT-DATA-TYPE) (DEFPROP %FIXNUM-MICROSECOND-TIME DTP-FIX RESULT-DATA-TYPE) ;An optimization is a several-to-several source to source transformation in MCLAP. ; It is expressed in pattern - action form. ; The pattern spans some number of instructions, and can match against various aspects ; of the instruction including code and operands. ; The action corresponds with the pattern and usually acts on the matched code. ;Optimization pattern matching "language" ; a list of transformations each of which is ; a list whose first element is ; a list each element of which is to be matched the code of an instruction. ; whose second element is ; a list of actions, the elements of which are corresponded with matched instructions ;Pattern variables are denoted by (== ..). ; can be a list, see discussion of name chaining below. ; Similiar to most pattern matching languages, pattern variables start out unassigned. ; The first time the variable is seen, it becomes assigned to whatever it was matched ; against. If the same variable is seen again, it must be matched against EQUAL ; list structure to its assignment in order for the match to succeed. ; The following pattern variables are special: ; ? matches anything, always. ; *INST* is the instruction being matched. ; *FUNCTION-ARG* is the argument to the current function. ; are LISP expressions. However, the proposed value for ; the variable is "stuck in" as the first arg. For example, (MEMQ (JUMP JUMP-NOT-EQUAL)) ; would restrict the variable to matching one of those symbols. ; Non-NIL symbols in the CDR position of lists are also pattern variables. ;variable chaining or "non-atomic" variables. ; The MAP-MATCH construct matches a single pattern to each of the members of a list. ;For example, the list of instructions that can preceed the current one. ; Since the same pattern is being reused multiple times, a mechanism ;is needed to "index" the variables, otherwise, they would be shared between all ;matches. This capability is provided by associating a control variable ;with the MAP-MATCH, then using this variable as part of a chained ;variable name. Since the control variable will change as the MAP-MATCH ;progresses, this provides unique variables for each application ;of the pattern. ; The variable *namechain* is the list of the control variables of currently ;nested MAP-MATCHs. This chain is postfixed by default to all generated ;pattern variables with names that are symbols. With a pattern variable whose ;name is a list, this postfixing can be suppressed or modified. In particular, ;(== (= foo)) suppresses all prefixing, and references foo. ;(== (* foo)) cdr's *namechain* before postfixing, thus referencing the previous ;"lexical" level. ; When the variable is "seen", all symbols but the first are replaced ;with their current values, thus forming the desired name. Note chained variables ;cannot be used in the dotted REST position, since they could not be recognized. ;However, an ordinary variable can be used to receive the value, and then the value ;moved into a "safe" chained variable via LET. ; MATCH-FUNCTIONs allow recursive patterns as well as "subroutinizing" pattern expressions. ;The "argument" of the function is the new binding for *namechain*. ; Similarily to a optimization, MATCH-FUNCTION has two parts, a pattern part ;and an action part. ; MATCH-CASE provides an OR capability (without duplicating the entire pattern). ;Furthermore, a control variable is associated which gets set to the path number ;that was successful. This variable is then available at ACTION time to select ;a corresponding ACTION via PUT-CASE. (DEFCONST *MA-OPT-TRACE-VARS* NIL) ;print when vars on this list assigned. (DEFCONST *MA-OPT-TRACE-ACTS* NIL) ;this can also be turned on by a (trace) ; term in the RHS of a rule. (DEFCONST *MA-OPT-TRACE-MAP-ACTS* NIL) (DEFCONST *MA-OPT-TRACE-MATCH* NIL) ;this can also be turned on by a (trace) ; term in the LHS of a rule. (DEFCONST *MA-OPT-TRACE-MAP-MATCH* NIL) (DEFCONST *MA-OPT-PRINT-INPUT* NIL) (DEFCONST *MA-OPT-PRINT-OUTPUT* NIL) (DEFVAR *NAMECHAIN* NIL) ;postfixed to pattern variables, see above. (DEFCONST *MA-OPTIMIZATIONS* '( ;flush move to self ( ( ((CODE (MOVE (== O) (== O) (== if1 (ma-no-byte-spec))) )) ) ( ((FLUSH) ) ) ) ;flush (move (push-pdl ...) (pdl-pop)). ( ( ((CODE (MOVE (push-pdl (== ?)) (pdl-pop) (== ?)) )) ) ( ((FLUSH) ) ) ) ;combine push followed immediately by pop. ( ( ((CODE (MOVE (PUSH-PDL (== ?)) (== S) (== if1) ))) ((CODE (MOVE (== D) (PDL-POP) (== if2)) )) ) ( ((FLUSH)) ((PUT (MOVE (== D) (== S) (== (ma-merge-info (== if1) (== if2)))))) ) ) ;combine move x s, ... move d,x where ... is within sequence and doesnt clobber x. ( ( ((CODE (MOVE (== D) (== X (SYMBOLP)) (== IF1))) (OP1-LIST (MA-ONE-AND-ONLY-USE-P)) (LET I2 (== *INST*)) (LET-APPLY-TEST I1 (MA-OP1-SOURCE-INST (== *INST*))) (MATCH (== I1) ((PRED (MA-SAME-SEQUENCE (== *INST*) (== I2))) (CODE (MOVE (== X) (== S) . REST)) (MAP-RANGE (== *INST*) (== I2) (== D) NO-REFERENCE) (MAP-RANGE (== *INST*) (== I2) (== X) NO-CLOBBER))))) ( ((FLUSH) (PUT-INST (== I1) ((PUT (MOVE (== D) (== S) . REST))))))) ;combine MOVE into following JUMP if arg can live in A-MEM. ( ( ((CODE (MOVE (== R) (== O (MA-CAN-LIVE-IN-A-MEM)) (== ?))) (RESULT-OP (MA-OPERAND-ONE-USE-P))) ;not used elsewhere ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL))) (== M) (== R) (UTAG (== TAG)))) ) ) ( ((FLUSH)) ((PUT ((== I) (== M) (== O) (UTAG (== TAG))))))) ;combine MOVE into following JUMP if MOVE is from register where it is already masked. ( ( ((CODE (MOVE (== R1) (== D1 (MA-REGISTERP)) (== ?))) (RESULT-OP (MA-OPERAND-ONE-USE-P))) ((CODE (MOVE (== R2) (== D2) (== ?)))) ;can't interact with above since JUMP is only use. ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL))) (== R1) (== R2) (UTAG (== TAG))))) ) ( ((FLUSH)) () ((PUT ((== I) (== D1) (== R2) (UTAG (== TAG))))))) ;also for the other arg. ( ( ((CODE (MOVE (== R2) (== D2 (MA-REGISTERP)) (== ?))) (RESULT-OP (MA-OPERAND-ONE-USE-P))) ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL))) (== R1) (== R2) (UTAG (== TAG)))) ) ) ( ((FLUSH)) ((PUT ((== I) (== R1) (== D2) (UTAG (== TAG))))))) ;if move to stack followed by move from top of stack to special variable, insert waypoint ; of T. Winds up generating better code and helps below frob collapse. ( ( ((code (move (push-pdl (== pd)) (== s) (== IF1)))) ((code (move (special (== sv)) (0 pp) (== IF2)))) ;T is free-p ) ( ((put (move t (== s) (== IF1)))) ((put (move (special (== sv)) t (== IF2)))) ((insert) (put (move (push-pdl (== pd)) t NIL))))) ;if move of special var to stack followed by cond-jump on special var, insert waypoint ; of T to avoid ref'ing special variable twice. This also helps the below frob collapse. ( ( ((code (move (push-pdl (== pd)) (special (== s)) (== IF1)))) ((code ((== i (memq (jump-equal jump-not-equal))) (special (== s)) (== a) (utag (== tag))))) ;T is free-p ) ( ((put (move t (special (== s)) (== IF1)))) ((put (move (push-pdl (== pd)) t (== IF1)))) ((insert) (put ((== i) t (== a) (utag (== tag))))))) ;flush lossage if a (MOVE T (PDL-POP)) is reached only by ; (MOVE (PDL-PUSH) T) or ; (MOVE (PDL-PUSH) T) (JUMP ..) or ; (MOVE (PDL-PUSH) T) ( T ..) (DISCARD-TOP-OF-STACK) or ;This happens quite frequently, due to CONDs. ( ( ((CODE (MOVE T (PDL-POP) (== ?))) (MATCH-FUNCTION OP-IN-T-AND-PDL ?))) ( ((MATCH-FUNCTION OP-IN-T-AND-PDL ?) (FLUSH)))) )) (DEFCONST *MA-ARITH-OPTIMIZATIONS* '( ;If "ARITH" instruction has a second source of PDL-POP, and that is a fixnum, ; move it into the instruction. That will probably result in it winding up in A-MEM ( ( ((code ((== i (memq (add sub and ior xor))) t (== s1) (pdl-pop) (== if1))) (op2 (ma-operand-move-of-fixnum-constant-p)) (op2-list (ma-one-and-only-use-p)) (let i2 (== *inst*)) (let-apply-test i1 (ma-ops-source-inst (== *inst*) 1)) ;2nd operand (match (== i1) ((pred (ma-same-sequence (== *inst*) (== i2))) (code (move (== x) (== s2) (== if2)))))) ) ( ((put ((== i) t (== s1) (== s2) (== if1))) (put-inst (== i1) ((flush))))) ) ;If "ARITH" instruction has a second source of PDL-POP, and that is not a fixnum, ; but is a stack variable (arg or local), try to flush the original push, and ; combine the ref into the "ARITH" inst. ; This must be the only use of that operand, it must not clobbered in the range in question, ; and the matching push must not be from a register. ( ( ((code ((== i (memq (add sub and ior xor))) t (== s1) (pdl-pop) (== if1))) (op2 (ma-operand-move-of-stack-var-p)) ;local or arg. (op2-list (ma-one-and-only-use-p)) (let i2 (== *inst*)) (let-apply-test i1 (ma-ops-source-inst (== *inst*) 1)) ;2nd operand (match (== i1) ((pred (ma-same-sequence (== *inst*) (== i2))) (code (move (== x) (== s2) (== if2))) (map-range (== *inst*) (== i2) (== s2) no-clobber)))) ) ( ((put ((== i) t (== s1) (== s2) (== if1))) (put-inst (== i1) ((flush))))) ) ; ;If a commutative ARITH instruction has second source of T, and first source of B, ; ; switch them and replace the B with the source of where it was loaded from. ; ( ( ((code ((== i (memq (add and ior xor))) t b t (== if1))) ; (op1-list (ma-one-and-only-use-p)) ; (let i2 (== *inst*)) ; (let-apply-test i1 (ma-ops-source-inst (== *inst*) 0)) ;1st operand ; (match (== i1) ; ((pred (ma-same-sequence (== *inst*) (== i2))) ; (code (move (== x) (== s2) (== if2))))))) ; ( ((put ((== i) t t (== s2) (== if1))) ; (put-inst (== i1) ; ((flush)))))) ; ;Fixnum constants can appear in the first source of an arith inst. ; ( ( ((code (move b (== s1) (== if1))) ; (op1 (ma-operand-move-of-fixnum-constant-p))) ; ((code ((== i (memq (add sub and ior xor))) t b (== s2) (== if2))) ; (op1-list (ma-one-and-only-use-p)))) ; ( ((put ((== i) t (== s1) (== s2) (== if2)))) ; ((flush)))) ;THE BELOW OPTIMIZATION IS NOT NECESSARY SINCE, IF IT APPLIES, THE REAL UINST WILL BE ; SAVED ANYWAY BY THE COMBINE-DEST HACK. ;If result of arith inst is used only to D-PDL, combine the D-PDL into the arith inst. ;Note that this can only be done with D-PDL since the cdr-code is not guarenteed. ; ( ( ((code ((== i (memq (add sub and ior xor))) t (== s1) (== s2) (== if1)))) ; ((code (move (push-pdl d-pdl) t nil)) ; (op1-list (ma-one-and-only-use-p)))) ; ( ((put ((== i) (push-pdl d-pdl) (== s1) (== s2) (== if1)))) ; ((flush)))) ;flush trap-unless-fixnum if arg can be shown to be fixed. It will take this path if ; its a fixnum-declared variable. ; ( ( ((code (trap-unless-fixnum (== s1) (== IF1))) ; (op1 (ma-operand-move-of-fix-p))) ) ; ( ((flush)) ) ) )) ;If there is a PUSH-PDL in all paths to the current instruction, factor ;it out and leave the result in T instead. If a non-? argument is supplied, ;it is a source which must have the same data as was pushed, or, in other ;words, the push must have been a (MOVE (PUSH-PDL ?) ). This is of ;interest when is being tested by a conditional jump. (DEFPROP OP-IN-T-AND-PDL ( ((LET IN (== *INST*)) (MAP-MATCH %%1 (MA-PRECEEDING-INSTS-LIST) ((MATCH-CASE OP ( ((CODE (MOVE (PUSH-PDL (== ?)) (== SOURCE) (== IF1))) ;drop thru (PRED (MA-MATCH-EQUAL (== (* *FUNCTION-ARG*)) (== SOURCE)))) ((CODE (JUMP NIL NIL (UTAG (== TAG)))) ;unconditional jump (MATCH-FUNCTION OP-IN-T-AND-PDL (== (* *FUNCTION-ARG*)))) ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL))) ;conditional jump T (== A) (UTAG (== TAG)))) (MATCH-FUNCTION OP-IN-T-AND-PDL T) (MAP-MATCH %%2 (MA-FOLLOWING-INSTS-LIST) ((MATCH-CASE C ( ((PRED (EQ (== *INST*) (== (* (* IN)))))) ((CODE (DISCARD-TOP-OF-STACK)))))))) ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL))) ;conditional jump (TOP-OF-PDL) (== A) (UTAG (== TAG)))) (MATCH-FUNCTION OP-IN-T-AND-PDL T) (MAP-MATCH %%3 (MA-FOLLOWING-INSTS-LIST) ((MATCH-CASE C ( ((PRED (EQ (== *INST*) (== (* (* IN)))))) ((CODE (DISCARD-TOP-OF-STACK)))))))) )) ))) ((MAP-PUT %%1 (MA-PRECEEDING-INSTS-LIST) ((PUT-CASE OP ( ((PUT (MOVE T (== SOURCE) (== IF1)))) ;drop thru ((MATCH-FUNCTION OP-IN-T-AND-PDL (== (* *FUNCTION-ARG*)))) ;unconditional jump ((MATCH-FUNCTION OP-IN-T-AND-PDL T) ;conditional jump (MAP-PUT %%2 (MA-FOLLOWING-INSTS-LIST) ((PUT-CASE C ( () ((FLUSH))))))) ((PUT ((== I) T (== A) (UTAG (== TAG)))) ;that which was on top of stack ;is now in T. Otherwise, same as above. (MATCH-FUNCTION OP-IN-T-AND-PDL T) ;conditional jump (MAP-PUT %%3 (MA-FOLLOWING-INSTS-LIST) ((PUT-CASE C ( () ((FLUSH))))))))))))) MA-OPT-FUNCTION) (DEFPROP M-EQ ( ;open code EQ ( ( ((CODE (MOVE (PUSH-PDL (== ?)) (== S) (== IF1)))) ((CODE (CALL (POPS 2) (== ?) (MISC-ENTRY M-EQ)))) ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL))) T A-V-NIL (UTAG (== TAG)))) (OP1-LIST (MA-ONE-AND-ONLY-USE-P))) ) ( ((PUT (MOVE C (PDL-POP) NIL))) ((PUT (MOVE B (== S) (== IF1))) ) ((PUT ((== I (MA-INVERT (JUMP-EQUAL JUMP-NOT-EQUAL))) C B (UTAG (== TAG))))) ) ) ) MA-OPTIMIZATIONS) (DEFPROP M-= ( ;open code =. Must know both operands are fixnums. ( ( ((CODE (MOVE (PUSH-PDL (== ?)) (== S) (== IF1)))) ((CODE (CALL (POPS 2) (== ?) (MISC-ENTRY M-=))) (STACK-OPERANDS-MAP (MA-OPERAND-MOVE-OF-FIX-P NIL))) ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL))) T A-V-NIL (UTAG (== TAG)))) (OP1-LIST (MA-ONE-AND-ONLY-USE-P))) ) ( ((PUT (MOVE C (PDL-POP) NIL))) ((PUT (MOVE B (== S) (== IF1))) ) ((PUT ((== I (MA-INVERT (JUMP-EQUAL JUMP-NOT-EQUAL))) C B (UTAG (== TAG))))) ) ) ) MA-OPTIMIZATIONS) (DEFPROP ZEROP ( ;open code ZEROP. Must know the operand is a fixnum. ( ( ((CODE (MOVE (PUSH-PDL (== ?)) (== S) (== IF1)))) ((CODE (CALL (POPS 1) (== ?) (MISC-ENTRY ZEROP))) (STACK-OPERANDS-MAP (MA-OPERAND-MOVE-OF-FIX-P NIL))) ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL))) T A-V-NIL (UTAG (== TAG)))) (OP1-LIST (MA-ONE-AND-ONLY-USE-P)))) ( ((PUT (MOVE T (== S) (== IF1)))) ((PUT ((== I (MA-ASSQ ((JUMP-NOT-EQUAL . JUMP-EQUAL) (JUMP-EQUAL . JUMP-NOT-EQUAL)))) T (QUOTE 0) (UTAG (== TAG))))) ((FLUSH))) ) ) MA-OPTIMIZATIONS) (DEFPROP FIXNUMP ( ( ( ((CODE (MOVE (PUSH-PDL (== ?)) (== S) (== IF1)))) ((CODE (CALL (POPS 1) (== ?) (MISC-ENTRY FIXNUMP)))) ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL))) T A-V-NIL (UTAG (== TAG)))) (OP1-LIST (MA-ONE-AND-ONLY-USE-P)))) (((PUT ((== I (MA-ASSQ ((JUMP-NOT-EQUAL . JUMP-DATA-TYPE-EQUAL) (JUMP-EQUAL . JUMP-DATA-TYPE-NOT-EQUAL)))) (== S) (QUOTE 0) (UTAG (== TAG))))) ;Any fixnum would do for second source. ((FLUSH)) ((FLUSH))) ) ) MA-OPTIMIZATIONS) (DEFPROP %DATA-TYPE ( ( ( ((CODE (MOVE (PUSH-PDL (== ?)) (== S) (== ?)))) ((CODE (CALL (POPS 1) (== ?) (MISC-ENTRY %DATA-TYPE)))) ) ( ((PUT (MOVE T (== S) ((BYTE-SPEC (DTP-FIX 5 25.)))))) ((FLUSH)) ) )) MA-OPTIMIZATIONS) (DEFPROP %POINTER ( ( ( ((CODE (MOVE (PUSH-PDL (== ?)) (== S) (== ?)))) ((CODE (CALL (POPS 1) (== ?) (MISC-ENTRY %POINTER)))) ) ( ((PUT (MOVE T (== S) ((BYTE-SPEC (DTP-FIX 25. 0)))))) ((FLUSH)) ) )) MA-OPTIMIZATIONS) (DEFPROP XTCADD ( ( ( ((CODE (CALL (POPS 1) (== IF1) (MC-LINKAGE XTCADD))) (RESULT-OP (MA-OPERAND-MOVE-OF-FIX-P NIL))) ) ( ((put (add t t (pdl-pop) (== if1))))) ;Follow ups ( ( ((code (move (push-pdl (== ?)) (== s1) (== if1)))) ((code (move t (== s2) (== if2)))) ((code (add t t (pdl-pop) (== if3))))) ( ((put (move t (== s1) (== if1)))) ((put (add t t (== s2) (== if2)))) ((flush)) ) ) ) ) MA-OPTIMIZATIONS) (DEFPROP XTCSUB ( ( ( ((CODE (CALL (POPS 1) (== IF1) (MC-LINKAGE XTCSUB))) (RESULT-OP (MA-OPERAND-MOVE-OF-FIX-P NIL)))) ( ((PUT (SUB T T (PDL-POP) (== IF1)))) ) ;Follow ups ( ( ((code (move (push-pdl (== ?)) t (== if1)))) ((code (move t (== s2) (== if2)))) ((code (sub t t (pdl-pop) (== if3))))) ( ((put (move b (== s2) (== if2)))) ((put (sub t b t (== if3)))) ((flush)) )) ( ( ((code (move (push-pdl (== ?)) (== s1) (== if1))) (pred (not (eq (== s1) 't)))) ;avoid above case, which would lose. ((code (move t (== s2) (== if2)))) ((code (SUB t t (pdl-pop) (== if3))))) ( ((put (move t (== s2) (== if2)))) ((put (SUB t t (== s1) (== if1)))) ((flush)) ) ) )) MA-OPTIMIZATIONS) (DEFPROP XTCAND ( ( ( ((CODE (CALL (POPS 1) (== IF1) (MC-LINKAGE XTCAND))) (STACK-OPERANDS-MAP (MA-OPERAND-MOVE-OF-FIX-P NIL)))) ( ((PUT (AND T T (PDL-POP) (== IF1)))) ) ;Follow ups ( ( ((code (move (push-pdl (== ?)) (== s1) (== if1)))) ((code (move t (== s2) (== if2)))) ((code (and t t (pdl-pop) (== if3))))) ( ((put (move t (== s1) (== if1)))) ((put (and t t (== s2) (== if2)))) ((flush)) ) ) ) ) MA-OPTIMIZATIONS) (DEFPROP XTCIOR ( ( ( ((CODE (CALL (POPS 1) (== IF1) (MC-LINKAGE XTCIOR))) (STACK-OPERANDS-MAP (MA-OPERAND-MOVE-OF-FIX-P NIL)))) ( ((PUT (IOR T T (PDL-POP) (== IF1)))) ) ;Follow ups ( ( ((code (move (push-pdl (== ?)) (== s1) (== if1)))) ((code (move t (== s2) (== if2)))) ((code (ior t t (pdl-pop) (== if3))))) ( ((put (move t (== s1) (== if1)))) ((put (ior t t (== s2) (== if2)))) ((flush)) ) ) )) MA-OPTIMIZATIONS) (DEFPROP XTCXOR ( ( ( ((CODE (CALL (POPS 1) (== IF1) (MC-LINKAGE XTCXOR))) (STACK-OPERANDS-MAP (MA-OPERAND-MOVE-OF-FIX-P NIL)))) ( ((PUT (XOR T T (PDL-POP) (== IF1)))) ) ;Follow ups ( ( ((code (move (push-pdl (== ?)) (== s1) (== if1)))) ((code (move t (== s2) (== if2)))) ((code (xor t t (pdl-pop) (== if3))))) ( ((put (move t (== s1) (== if1)))) ((put (xor t t (== s2) (== if2)))) ((flush)) ) ) )) MA-OPTIMIZATIONS) (DEFPROP 1+ ( ( ( ((code (call (pops 1) (== if1) (misc-entry 1+))) (result-op (ma-operand-move-of-fix-p nil)))) ( ((put (add t (quote 1) (pdl-pop) (== if1)))) ) ;Follow ups ( ( ((code (move (push-pdl (== ?)) (== s1) (== if1)))) ((code (add t (quote 1) (pdl-pop) (== if2))))) ( ((put (add t (quote 1) (== s1) (== if2)))) ((flush)) ) ) )) ma-optimizations) (DEFPROP 1- ( ( ( ((code (call (pops 1) (== if1) (misc-entry 1-))) (result-op (ma-operand-move-of-fix-p nil)))) ( ((put (add t (quote -1) (pdl-pop) (== if1)))) ) ;Follow ups ( ( ((code (move (push-pdl (== ?)) (== s1) (== if1)))) ((code (add t (quote -1) (pdl-pop) (== if2))))) ( ((put (add t (quote -1) (== s1) (== if2)))) ((flush)) ) ) )) ma-optimizations) (defprop m-< ( ( ( ((code (move (push-pdl (== ?)) (== s) (== if1)))) ((code (call (pops 2) (== ?) (misc-entry m-<))) (stack-operands-map (ma-operand-move-of-fix-p nil))) ((code ((== i (memq (jump-equal jump-not-equal))) t a-v-nil (utag (== tag)))) (op1-list (ma-one-and-only-use-p)))) ( ((put (move m-1 (pdl-pop) ((output-selector sign-extend-25))))) ((put (move m-2 (== s) (== (ma-merge-info ((output-selector sign-extend-25)) (== if1)))))) ((put ((== i (ma-assq ((jump-not-equal . jump-less-than) (jump-equal . jump-greater-or-equal)))) m-1 m-2 (utag (== tag))))) ) ) ) ma-optimizations) (defprop m-> ( ( ( ((code (move (push-pdl (== ?)) (== s) (== if1)))) ((code (call (pops 2) (== ?) (misc-entry m->))) (stack-operands-map (ma-operand-move-of-fix-p nil))) ((code ((== i (memq (jump-equal jump-not-equal))) t a-v-nil (utag (== tag)))) (op1-list (ma-one-and-only-use-p)))) ( ((put (move m-1 (pdl-pop) ((output-selector sign-extend-25))))) ((put (move m-2 (== s) (== (ma-merge-info ((output-selector sign-extend-25)) (== if1)))))) ((put ((== i (ma-assq ((jump-not-equal . jump-greater-than) (jump-equal . jump-less-or-equal)))) m-1 m-2 (utag (== tag))))) ) ) ) ma-optimizations) (defprop ldb ( ( ( ((code (move (push-pdl (== ?)) (== s) (== if1)))) ((code (call (pops 2) (== ?) (misc-entry ldb))) (stack-operands-map (ma-operand-move-of-fix-p nil)) (op1 (ma-operand-move-of-fixnum-constant-p)) (op1-list (ma-one-and-only-use-p)) (let i2 (== *inst*)) (let-apply-test i1 (ma-op1-source-inst (== *inst*))) (match (== i1) ((pred (ma-same-sequence (== *inst*) (== i2))) (code (move (== x) (== s2) (== if2))))))) ( ((flush)) ((put (move t (== s) (== if1 (ma-add-byte-spec-from-op1)))) (put-inst (== i1) ((flush)))) )) ) ma-optimizations) (comment ;array reference optimizations: (defprop ar-1 ( ( ( ((code (move (push-pdl (== ?)) (== s) (== IF1)))) ((code (call (pops 2) (== a1) (misc-entry ar-1)))) ) ( ((put (trap-unless-fixnum (== s) (== IF1)))) ((put (move q (== s) ((BYTE-SPEC (0 25. 0)))))) ((insert) (put (call (pops 1) (== a1) (mc-linkage array-decode-1)))) ((insert) (put (dispatch-xct-next 0 %%array-type-field b (mc-linkage array-type-ref-dispatch)))) ) ;these transformations tried after above one succeeds. ;flush trap-unless-fixnum if testing a constant. ( ( ((code (trap-unless-fixnum (== s1) (== IF1))) (fixnum-checker-not-using-operands (== if1))) ) ( ((flush)) ) ) ;if instruction just before is a push-pdl, reshuffle winding up with a dispatch-start-read ; and direct dispatch instead of call. ( ( ((code (move (push-pdl (== ?)) (== s) (== IF1)))) ((code (move q (== qs) (== IF2)))) ((code (call (pops 1) (== ?) (mc-linkage array-decode-1)))) ) ( ((put (move q (== qs) (== IF2)))) ((put (move a (== s) (== IF1)))) ((put (dispatch-xct-next-write-vma 0 %%q-data-type a (mc-linkage array-decode-1-dispatch)))) ) ( ( ((code (move a (== s) (== ?)))) ((code (dispatch-xct-next-write-vma 0 %%q-data-type a (mc-linkage array-decode-1-dispatch))) (array-context-still-valid (== s)))) ( ((flush)) ;flush these if same array still set up from previously. ((flush)) ) ) ) ) ) ma-optimizations) (defprop xt-set-ar1 ( ;first try to "pull" the second arg to immediately before the xt-set-ar1 ( ( ((code (call (pops 2) (== ?) (mc-linkage xt-set-ar1))) (ops-list (ma-pullable-arg-p) 1) ;ops-list is 0 based, this gets 2nd arg (let set-ar1 (== *inst*)) (let-apply-test source-a2 (ma-ops-source-inst (== set-ar1) 1)) ;as above. (pred (ma-same-sequence (== source-a2) (== set-ar1))) (pred (ma-not-immediately-before (== source-a2) (== set-ar1))) ;avoid infinite loop (match (== source-a2) ((CODE (MOVE (== X) (== S) . REST)) (MAP-RANGE (== source-a2) (== set-ar1) (== S) NO-CLOBBER)))) ) ( ((insert) (put (== (ma-inst-code (== source-a2)))) (put-inst (== source-a2) ((flush))))) ) ;assuming the above has been done and we have recycled, try to pull the first arg. ( ( ((code (move (push-pdl (== ?)) (== s1) (== ?))) (let i2 (== *inst*))) ((code (call (pops 2) (== ?) (mc-linkage xt-set-ar1))) (ops-list (ma-pullable-arg-p) 0) ;first arg (let set-ar1 (== *inst*)) (let-apply-test source-a1 (ma-ops-source-inst (== set-ar1) 0)) (pred (ma-same-sequence (== source-a1) (== set-ar1))) (pred (ma-not-immediately-before (== source-a1) (== i2))) (match (== source-a1) ((code (move (== x) (== s) . rest)) (map-range (== source-a1) (== set-ar1) (== s) no-clobber)))) ) ( ((insert) (put (== (ma-inst-code (== source-a1)))) (put-inst (== source-a1) ((flush))))) ) ;assuming both of those have been done and we have recycled, this may win! ( ( ((code (move (push-pdl (== ?)) (== s1) (== IF1)))) ((code (move (push-pdl (== ?)) (== s2) (== IF2)))) ((code (call (pops 2) (== ?) (mc-linkage xt-set-ar1))))) ( ((put (trap-unless-fixnum (== s2) (== IF2)))) ((put (move q (== s2) ((BYTE-SPEC (0 25. 0)))))) ((put (move a (== s1) (== IF1)))) ((insert) (put (dispatch-xct-next-write-vma 0 %%q-data-type a (mc-linkage array-decode-1-dispatch)))) ((insert) (put (dispatch-xct-next 0 %%array-type-field b (mc-linkage array-type-store-dispatch-pushj)))) ) ;these transformations tried after above one succeeds. ;flush trap-unless-fixnum if testing a constant. ( ( ((code (trap-unless-fixnum (== s1) (== IF1))) (fixnum-checker-not-using-operands (== if1))) ) ( ((flush)) ) ) ( ( ((code (move a (== s) (== ?)))) ((code (dispatch-xct-next-write-vma 0 %%q-data-type a (mc-linkage array-decode-1-dispatch))) (array-context-still-valid (== s)))) ( ((flush)) ;flush these if same array still set up from previously. ((flush)) ) ) ) ) ma-optimizations) ) ;end comment (defprop qma ( ( ( ((code (call (pops 0) (== ?) (mc-linkage qma)))) ) ( ((put (dispatch-xct-next-write-vma (mc-linkage instance-invoke-car) %%q-data-type t (mc-linkage car-pre-dispatch-direct)))) ) )) ma-optimizations) (defprop qmd ( ( ( ((code (call (pops 0) (== ?) (mc-linkage qmd)))) ) ( ((put (dispatch-xct-next-write-vma (mc-linkage instance-invoke-cdr) %%q-data-type t (mc-linkage cdr-pre-dispatch-direct)))) ) )) ma-optimizations) (DEFUN MA-OPTIMIZE NIL (if *ma-grubble* (ma-grubble 0)) (PROG (*MA-OPT-FLAG*) (IF *MA-OPT-PRINT-INPUT* (MA-PRINT-CODE)) (CATCH 'MA-OPT-RECYCLE ;THROW HERE TO DO THE WHOLE THING OVER IF NECESSARY (DOLIST (SEQ *MA-SEQUENCES*) ; BECAUSE IT MAY NOT BE LINKED RIGHT DUE TO PREV OPTS. (MA-OPT-SEQUENCE SEQ))) (IF *MA-OPT-PRINT-OUTPUT* (MA-PRINT-CODE)) (RETURN *MA-OPT-FLAG*))) (DEFUN MA-OPT-RECYCLE NIL ;CALL HERE IF RECYCLE NECESSARY (SETQ *MA-OPT-FLAG* T) (THROW 'MA-OPT-RECYCLE NIL)) (DEFUN MA-OPT-RECYCLE-SEQ NIL (SETQ *MA-OPT-FLAG* T) (THROW 'OPT-SEQUENCE NIL)) (DEFUN MA-OPT-SEQUENCE (*SEQ*) (CATCH 'OPT-SEQUENCE (PROG (INSTS MISC-ENTRIES CODE) (SETQ INSTS (MA-ELEM-MEMBERS *SEQ*)) (DOLIST (I INSTS) ;misc-entries gets all such that appear in seq. (COND ((NOT (SYMBOLP I)) (SETQ CODE (MA-INST-CODE I)) (COND ((AND (CONSP CODE) (EQ (CAR CODE) 'CALL) (CONSP (CAR (LAST CODE))) (MEMQ (CAAR (LAST CODE)) '(MISC-ENTRY MC-LINKAGE))) (SETQ MISC-ENTRIES (CONS (CADAR (LAST CODE)) MISC-ENTRIES))))))) L (COND ((NULL INSTS) (RETURN NIL))) (MA-OPT-MATCH-LIST INSTS *MA-OPTIMIZATIONS*) (IF (MA-ARITH-INSTS-PRESENT INSTS) (MA-OPT-MATCH-LIST INSTS *MA-ARITH-OPTIMIZATIONS*)) (DOLIST (ME MISC-ENTRIES) (MA-OPT-MATCH-LIST INSTS (GET ME 'MA-OPTIMIZATIONS))) (SETQ INSTS (CDR INSTS)) (GO L)))) (DEFUN MA-ARITH-INSTS-PRESENT (INSTS) (DOLIST (INST INSTS) (COND ((MEMQ (CAR (MA-INST-CODE INST)) '(ADD SUB AND IOR XOR)) (RETURN T))))) (DEFUN MA-OPT-MATCH-LIST (INSTS OPT-LIST) (DOLIST (OPT OPT-LIST) (LET ((PATTERN (CAR OPT)) (ACTIONS (CADR OPT))) (IF (>= (LENGTH INSTS) (LENGTH PATTERN)) (MULTIPLE-VALUE-BIND (MATCH-P ALIST) (MA-OPT-MATCH INSTS PATTERN NIL) (COND (MATCH-P (MA-OPT-ACT INSTS ACTIONS ALIST) (MA-OPT-MATCH-SEQ-RECURSIVE (MA-ELEM-MEMBERS *SEQ*) (CDDR OPT)) (COND ((MA-SEQ-CHANGED *SEQ*) (THROW 'OPT-SEQUENCE T)))))))))) ;ONCE ONE PATTERN HAS BEEN MATCHED AND ACTIONS TAKEN, OPERANDS, ETC ARE NOT VALID ; SINCE THEY HAVE NOT BEEN UPDATED. STILL IT IS USEFUL TO RUN A LIST OF OPTIMIZATIONS ; ASSOCIATED WITH THE ONE ORIGINALLY MATCHED, SINCE FURTHER FIXUPS MAY BE POSSIBLE AND ; WE DONT WANT TO HAVE TO PUT THE IN *MA-OPTIMIZATIONS* AND SLOW EVERYTHING DOWN ALL THE ; TIME WORRYING ABOUT THEM. SO THIS RECURSIVE MATCH HACKER IS CALLED. IT DIFFERS FROM ; THE MAIN ONE IN THAT IT DOESNT THROW OUT (THE OPTIMIZATIONS ARE SUPPOSED TO KNOW THE ; THEY ARE RUNNING IN A "MUNGED" ENVIRONMENT). ALSO, IT IS CAREFUL NOT TO GET SCREWWED ; BY THINGS GETTING ADDED BY PUT-INSERT. (DEFUN MA-OPT-MATCH-SEQ-RECURSIVE (INSTS OPT-LIST) (PROG () L (COND ((NULL INSTS) (RETURN NIL))) (COND ((MA-OPT-MATCH-LIST-RECURSIVE INSTS OPT-LIST) (SETQ INSTS (MA-ELEM-MEMBERS *SEQ*)) (GO L)) (T (SETQ INSTS (CDR INSTS)) (GO L))))) (DEFUN MA-OPT-MATCH-LIST-RECURSIVE (INSTS OPT-LIST &AUX VAL) (DOLIST (OPT OPT-LIST) (LET ((PATTERN (CAR OPT)) (ACTIONS (CADR OPT))) (IF (>= (LENGTH INSTS) (LENGTH PATTERN)) (MULTIPLE-VALUE-BIND (MATCH-P ALIST) (MA-OPT-MATCH INSTS PATTERN NIL) (COND (MATCH-P (MA-OPT-ACT INSTS ACTIONS ALIST) (MA-OPT-MATCH-SEQ-RECURSIVE (MA-ELEM-MEMBERS *SEQ*) (CDDR OPT)) (SETQ INSTS (MA-ELEM-MEMBERS *SEQ*) VAL T))))))) VAL) (DEFUN MA-OPT-MATCH (INSTS PATTERN ALIST) (PROG (MATCH-P P I) L (COND ((NULL PATTERN) (RETURN T ALIST)) ((NULL INSTS) ;should not get here unless enuf insts to maybe win (FERROR NIL "insts too short"))) (SETQ P (CAR PATTERN) I (CAR INSTS)) (MULTIPLE-VALUE (MATCH-P ALIST) (MA-OPT-MATCH-INST I P ALIST NIL)) (COND ((NULL MATCH-P) (RETURN NIL ALIST))) (SETQ INSTS (CDR INSTS) PATTERN (CDR PATTERN)) (GO L))) (DEFUN MA-OPT-MATCH-INST (*INST* *PATTERN* *ALIST* *NAMECHAIN*) (LET ((*MA-OPT-TRACE-MATCH* *MA-OPT-TRACE-MATCH*)) (PROG (MATCH-P P-ELEM FCTN) (COND ((NULL *INST*) (RETURN NIL *ALIST*))) (COND (*MA-OPT-TRACE-MATCH* (FORMAT T "~% begin match ~S, pat ~S, alist ~s" *INST* *PATTERN* *ALIST*))) L (COND ((NULL *PATTERN*) (COND (*MA-OPT-TRACE-MATCH* (FORMAT T "~% match on ~s succeeded" *INST*))) (RETURN T *ALIST*))) (SETQ P-ELEM (CAR *PATTERN*)) (IF (NULL (SETQ FCTN (GET (CAR P-ELEM) 'MA-OPT-MATCHER))) (FERROR NIL "unknown type match") (SETQ MATCH-P (FUNCALL FCTN (CDR P-ELEM)))) (COND ((NULL MATCH-P) (COND (*MA-OPT-TRACE-MATCH* (FORMAT T "~% match on ~S failed, P-ELEM ~S" *INST* P-ELEM))) (RETURN NIL *ALIST*))) (SETQ *PATTERN* (CDR *PATTERN*)) (GO L)))) (DEFUN (CODE MA-OPT-MATCHER) (PAT) (MA-OPT-MATCH-WD (MA-INST-CODE *INST*) (CAR PAT))) (DEFUN (OP1 MA-OPT-MATCHER) (PAT) (AND (NULL (MA-INST-CHANGED *INST*)) (NULL (DOLIST (OP (CDR (first (MA-INST-OPs *INST*)))) ;pred must be true of (COND ((NULL (MA-OPT-APPLY OP (CAR PAT))) (RETURN T))))))) ;all possibilities (DEFUN (OP2 MA-OPT-MATCHER) (PAT) (AND (NULL (MA-INST-CHANGED *INST*)) (NULL (DOLIST (OP (CDR (second (MA-INST-OPs *INST*)))) (COND ((NULL (MA-OPT-APPLY OP (CAR PAT))) (RETURN T))))))) (DEFUN (RESULT-OP MA-OPT-MATCHER) (PAT) (MA-OPT-APPLY-INST (MA-INST-RESULT-OPERAND *INST*) (CAR PAT))) (DEFUN (OP1-LIST MA-OPT-MATCHER) (PAT) (MA-OPT-APPLY-INST (CDR (first (MA-INST-OPs *INST*))) (CAR PAT))) (defun (ops-list ma-opt-matcher) (pat) ;second pattern element says do it to Nth arg. (ma-opt-apply-inst (cdr (nth (cadr pat) (ma-inst-ops *inst*))) (car pat))) (DEFUN (OP2-LIST MA-OPT-MATCHER) (PAT) (MA-OPT-APPLY-INST (CDR (second (MA-INST-OPs *INST*))) (CAR PAT))) (DEFUN (STACK-OPERANDS-MAP MA-OPT-MATCHER) (PAT) (AND (NULL (MA-INST-CHANGED *INST*)) (NULL (CATCH 'VAL (DOLIST (OPL (MA-INST-OPs *INST*)) (DOLIST (OP (CDR OPL)) (COND ((NULL (MA-OPT-APPLY OP (CAR PAT))) (THROW 'VAL T))))))))) ;SAVE FOR USE IN RECURSIVE MATCHERS (IE, DOES NOT DEPEND ON OPERANDS) (defun (fixnum-checker-not-using-operands ma-opt-matcher) (pat) (LET ((C (CADR (MA-INST-CODE *INST*))) (info-list (ma-opt-subs (car pat)))) (ma-fixnump c info-list) ; (COND ((NOT (EQ (CAR C) 'CONSTANT)) ; (FERROR NIL "FIXNUM CHECKER LOSSAGE")) ; (T (LET ((DTP (LDB %%Q-DATA-TYPE (CADR C)))) ; (OR (= DTP DTP-FIX) ; (= DTP DTP-CHARACTER))))) )) (defun (array-context-still-valid ma-opt-matcher) (pat) (prog (i source subs-pattern) (setq subs-pattern (ma-opt-subs pat) source (car subs-pattern)) ; (format t "~%Looking back for array setup of ~s" source) (cond ((not (ma-source-comes-from-known-source-p source)) ; (format t "~% unknown source") (return nil))) (setq i (ma-inst-previous-inst *inst*)) (setq i (ma-inst-previous-inst i)) ;space past move a, and dispatch- l (cond ((symbolp i) ; (format t "~%reached beginning of world") (return nil)) ((eq i (car (ma-elem-members *seq*))) ; (format t "~%reached beginning of seq") (return nil)) ((ma-code-is-dispatch-with-table-p (ma-inst-code i) 'array-decode-1-dispatch) ; (format t "~%found previous array setup") (setq i (ma-inst-previous-inst i)) (cond ((symbolp i) (return nil)) (t (let ((c (ma-inst-code i))) (return (and (eq (car c) 'move) (eq (cadr c) 'a) (equal (caddr c) source))))))) ((ma-inst-affects-registers source '(a b e s) i) ; (format t "~%Context destroyed by ~s" (ma-inst-code i)) (return nil))) (setq i (ma-inst-previous-inst i)) (go l))) (defun ma-source-comes-from-known-source-p (source) (and (listp source) (memq (car source) '(arg local)))) (defun ma-code-is-dispatch-with-table-p (code table) (and (listp code) (memq (car code) '(dispatch dispatch-xct-next dispatch-xct-next-write-vma)) (eq (car (car (last code))) 'mc-linkage) (eq (cadr (car (last code))) table))) (defun ma-inst-affects-registers (source registers inst) ;return T in case of any doubt. (let* ((code (ma-inst-code inst)) (c-code (ma-context-clobberage code))) (cond ((not (listp code)) t) ((and (eq (car code) 'move) (or (and (listp (cadr code)) (eq (car (cadr code)) 'push-pdl)) (and (symbolp (cadr code)) (not (memq (cadr code) registers))) (and (listp (cadr code)) (memq (car (cadr code)) '(arg local)) (not (equal (cadr code) source))))) nil) (t (prog (flag arg) (cond ((eq c-code t) ;(format t "~% c-code T") (return t))) l (cond ((null c-code) ;(format t "~% c-code NIL") (return t))) (setq flag (car c-code) arg (cadr c-code) c-code (cddr c-code)) (cond ((eq flag 'registers-clobbered) (return (dolist (r arg) (cond ((memq r registers) (format t "~%~s clobbered" r) (return t)))))) ((eq flag 'registers-preserved) (return (dolist (r registers) (cond ((not (memq r arg)) (format t "~%~s needed by not preserved" r) (return t)))))) ((eq flag 'operand-returned) (cond ((memq arg registers) (return t)))) (t (ferror nil "unknown clobberage code ~s" flag))) (go l)))))) (DEFUN (LET MA-OPT-MATCHER) (PAT) (MA-OPT-LET (CAR PAT) (CADR PAT)) T) (DEFUN MA-OPT-LET (SYM VAL) (LET ((ISYM (MA-OPT-EXPAND-CHAIN-VAR SYM))) (SETQ *ALIST* (CONS (CONS ISYM (MA-OPT-SUBS VAL)) *ALIST*)))) (DEFUN (LET-APPLY-TEST MA-OPT-MATCHER) (PAT) (LET ((SYM (MA-OPT-EXPAND-CHAIN-VAR (CAR PAT)))) (LET* ((EXP (MA-OPT-SUBS (CADR PAT))) (VAL (APPLY (CAR EXP) (CDR EXP)))) (IF (NULL VAL) NIL (SETQ *ALIST* (CONS (CONS SYM VAL) *ALIST*)) T)))) (DEFUN (MATCH MA-OPT-MATCHER) (PAT) (MULTIPLE-VALUE (NIL *ALIST*) (MA-OPT-MATCH-INST (MA-OPT-SUBS (CAR PAT)) (CADR PAT) *ALIST* *NAMECHAIN*))) (DEFUN (MAP-MATCH MA-OPT-MATCHER) (PAT) (PROG (CONTROL-VAR CONTROL-VAR-PNTR LIST-TO-MAP PATTERN) (SETQ CONTROL-VAR (CAR PAT) LIST-TO-MAP (MA-OPT-APPLY *INST* (CADR PAT)) PATTERN (CADDR PAT)) (SETQ CONTROL-VAR (MA-OPT-EXPAND-CHAIN-VAR CONTROL-VAR)) (SETQ *ALIST* (CONS (SETQ CONTROL-VAR-PNTR (CONS CONTROL-VAR 0)) *ALIST*)) (SETQ *ALIST* (CONS (CONS (CONS 'LTM CONTROL-VAR) LIST-TO-MAP) *ALIST*)) (SETQ *NAMECHAIN* (CONS CONTROL-VAR *NAMECHAIN*)) (COND (*MA-OPT-TRACE-MAP-MATCH* (FORMAT T "~% Map match pat ~s, ~s" pattern list-to-map))) L (COND ((NULL LIST-TO-MAP) (RETURN T))) (cond (*ma-opt-trace-map-match* (format t "~% Trying map-match on ~s" (car list-to-map)))) (COND ((NULL (MULTIPLE-VALUE (NIL *ALIST*) (MA-OPT-MATCH-INST (CAR LIST-TO-MAP) PATTERN *ALIST* *NAMECHAIN*))) (cond (*ma-opt-trace-map-match* (format t "~% map-match failed"))) (RETURN NIL))) (SETQ LIST-TO-MAP (CDR LIST-TO-MAP)) (RPLACD CONTROL-VAR-PNTR (1+ (CDR CONTROL-VAR-PNTR))) (GO L))) (DEFUN (MAP-PUT MA-OPT-ACT) (ACT) (PROG (CONTROL-VAR CONTROL-VAR-PNTR LIST-TO-MAP ACT-LIST C) (SETQ C 0 CONTROL-VAR (CAR ACT) ;LIST-TO-MAP (MA-OPT-APPLY *INST* (CADR ACT)) ACT-LIST (CADDR ACT)) (SETQ CONTROL-VAR (MA-OPT-EXPAND-CHAIN-VAR CONTROL-VAR)) (SETQ LIST-TO-MAP (CDR (ASSOC (CONS 'LTM CONTROL-VAR) *ALIST*))) (SETQ *ALIST* (CONS (SETQ CONTROL-VAR-PNTR (CONS CONTROL-VAR 0)) *ALIST*)) (SETQ *NAMECHAIN* (CONS CONTROL-VAR *NAMECHAIN*)) (COND (*MA-OPT-TRACE-MAP-ACTS* (FORMAT T "~% MAP-PUT: control-var ~s, list-to-map ~S" CONTROL-VAR LIST-TO-MAP))) L (COND ((NULL LIST-TO-MAP) (RETURN T))) (COND (*MA-OPT-TRACE-MAP-ACTS* (FORMAT T "~% MAP-PUT control-var ~s, case ~d, item ~s" CONTROL-VAR C (CAR LIST-TO-MAP)))) (MA-OPT-ACT-ON (CAR LIST-TO-MAP) ACT-LIST *NAMECHAIN*) (SETQ LIST-TO-MAP (CDR LIST-TO-MAP)) (RPLACD CONTROL-VAR-PNTR (1+ (CDR CONTROL-VAR-PNTR))) (SETQ C (1+ C)) (GO L))) (DEFUN (MATCH-CASE MA-OPT-MATCHER) (PAT) (PROG (CONTROL-VAR CONTROL-VAR-PNTR LIST-OF-CASES TEM-ALIST C) (SETQ C 0 CONTROL-VAR (CAR PAT) LIST-OF-CASES (CADR PAT)) (SETQ CONTROL-VAR (MA-OPT-EXPAND-CHAIN-VAR CONTROL-VAR)) (COND ((ASSOC CONTROL-VAR *ALIST*) (FERROR NIL "~% control variable has reused name ~S" CONTROL-VAR))) (SETQ *ALIST* (CONS (SETQ CONTROL-VAR-PNTR (CONS CONTROL-VAR 0)) *ALIST*)) (COND ((OR *MA-OPT-TRACE-MATCH* *MA-OPT-TRACE-MAP-MATCH*) (FORMAT T "~% MATCH-CASE: control-var ~S" CONTROL-VAR))) L (COND ((NULL LIST-OF-CASES) (RETURN NIL)) ((MULTIPLE-VALUE (NIL TEM-ALIST) (MA-OPT-MATCH-INST *INST* (CAR LIST-OF-CASES) *ALIST* *NAMECHAIN*)) (SETQ *ALIST* TEM-ALIST) ;this one won, gobble (FORMAT T "~% MATCH-CASE controlled by ~s won on case ~D" CONTROL-VAR C) (RETURN T))) (SETQ LIST-OF-CASES (CDR LIST-OF-CASES)) (RPLACD CONTROL-VAR-PNTR (1+ (CDR CONTROL-VAR-PNTR))) (SETQ C (1+ C)) (GO L) )) (DEFUN (PUT-CASE MA-OPT-ACT) (ACT) (PROG (CONTROL-VAR CONTROL-VAR-VAL LIST-OF-CASES) (SETQ CONTROL-VAR (CAR ACT) LIST-OF-CASES (CADR ACT)) (SETQ CONTROL-VAR (MA-OPT-EXPAND-CHAIN-VAR CONTROL-VAR)) (IF (NOT (NUMBERP (SETQ CONTROL-VAR-VAL (MA-OPT-SYMEVAL CONTROL-VAR)))) (FERROR NIL "control var not number")) (IF (OR *MA-OPT-TRACE-ACTS* *MA-OPT-TRACE-MAP-ACTS*) (FORMAT T "~%Taking case ~s, control var ~s, namechain ~s" CONTROL-VAR-VAL CONTROL-VAR *NAMECHAIN*)) (RETURN (MA-OPT-ACT-ON *INST* (NTH CONTROL-VAR-VAL LIST-OF-CASES) *NAMECHAIN*)) )) (DEFUN (MATCH-FUNCTION MA-OPT-MATCHER) (PAT) (LET* ((FCTN (CAR PAT)) (EXP (GET FCTN 'MA-OPT-FUNCTION))) (MA-OPT-LET '*FUNCTION-ARG* (CADR PAT)) (MULTIPLE-VALUE (NIL *ALIST*) (MA-OPT-MATCH-INST *INST* (CAR EXP) *ALIST* *NAMECHAIN*)))) (DEFUN (MATCH-FUNCTION MA-OPT-ACT) (ACT) (LET* ((FCTN (CAR ACT)) (EXP (GET FCTN 'MA-OPT-FUNCTION))) (MA-OPT-ACT-ON *INST* (CADR EXP) *NAMECHAIN*))) (DEFUN (PRED MA-OPT-MATCHER) (PAT) (LET ((F (CAAR PAT)) (ARGS (MA-OPT-SUBS (CDAR PAT)))) (IF *MA-OPT-TRACE-MATCH* (FORMAT T "~%pred: ~s args ~s" F ARGS)) (APPLY F ARGS))) (DEFUN MA-MATCH-EQUAL (A B) (OR (EQ A '?) (EQ B '?) (EQUAL A B))) (DEFUN (MAP-RANGE MA-OPT-MATCHER) (PAT) (LEXPR-FUNCALL 'MA-SEQ-MAP-RANGE *SEQ* ;args: from-inst to-inst slot pred (MA-OPT-SUBS PAT))) (DEFUN (TRACE MA-OPT-MATCHER) (PAT) PAT (FORMAT T "~% begin trace ~S, pat ~S, alist ~S" *INST* *PATTERN* *ALIST*) (SETQ *MA-OPT-TRACE-MATCH* T)) ;returns T (DEFUN (TRACE MA-OPT-ACT) (ACT) ACT (FORMAT T "~% begin act trace, inst ~s, alist ~s" *inst* *alist*) (SETQ *MA-OPT-TRACE-ACTS* T)) (DEFUN (BREAK MA-OPT-MATCHER) (PAT) PAT (CERROR T NIL NIL "break") T) (DEFUN (BREAK MA-OPT-ACT) (PAT) PAT (CERROR T NIL NIL "break") T) ;test instructions after FROM and before TO (DEFUN MA-SEQ-MAP-RANGE (SEQ FROM TO SLOT OPER) (PROG (INSTS) (SETQ INSTS (MA-ELEM-MEMBERS SEQ)) L (COND ((NULL INSTS) (FERROR NIL "p1")) ((EQ (CAR INSTS) FROM) (GO E1))) (SETQ INSTS (CDR INSTS)) (GO L) E1 (SETQ INSTS (CDR INSTS)) ;flush from INST. L1 (COND ((NULL INSTS) (FERROR NIL "p2")) ((EQ (CAR INSTS) TO) (RETURN T)) ;doesnt clobber ((MA-INST-MAP-OPER-P (CAR INSTS) SLOT OPER) (COND (*MA-OPT-TRACE-MATCH* (FORMAT T "~% ~s violates ~s ~s" (CAR INSTS) OPER SLOT))) (RETURN NIL))) ;does clobber (SETQ INSTS (CDR INSTS)) (GO L1) )) (DEFUN MA-INST-MAP-OPER-P (INST SLOT OPER) (SELECTQ OPER (NO-CLOBBER (COND ((MA-INST-CLOBBERS-SLOT-P SLOT INST)) ((EQUAL SLOT (MA-DEST-CODE INST))))) (NO-REFERENCE (dolist (op (ma-inst-ops inst)) (cond ((ma-operand-refs-slot slot op) (return t)))) ;(OR (MA-OPERAND-REFS-SLOT SLOT (MA-INST-OP1 INST)) ; (MA-OPERAND-REFS-SLOT SLOT (MA-INST-OP2 INST))) ))) (DEFUN MA-INST-CLOBBERS-SLOT-P (SLOT INST) (PROG (C-CODE FLAG ARG) (COND ((AND (LISTP SLOT) (MEMQ (CAR SLOT) '(CONSTANT QUOTE))) (RETURN NIL)) ((AND (LISTP SLOT) (MEMQ (CAR SLOT) '(ARG LOCAL))) (RETURN NIL)) ;nothing clobbers these except insts, tested for above. ) ;slot could be special or a register past here. (COND ((EQ T (SETQ C-CODE (MA-CONTEXT-CLOBBERAGE (MA-INST-CODE INST)))) (RETURN T))) ;CLOBBERS ALL L (COND ((NULL C-CODE) (RETURN NIL))) (SETQ FLAG (CAR C-CODE) ARG (CADR C-CODE) C-CODE (CDDR C-CODE)) (COND ((EQ FLAG 'REGISTERS-CLOBBERED) (COND ((SYMBOLP ARG) (IF (MA-REGISTERP SLOT) (RETURN T))) ((MEMQ SLOT ARG) (RETURN T)))) ((eq flag 'registers-preserved) (return (if (or (not (ma-registerp slot)) (memq slot arg)) nil t))) ((eq flag 'operand-returned) (cond ((eq slot arg) (return t)))) (T (FERROR NIL "UNKNOWN CLOBBERAGE CODE ~S" FLAG))) (GO L)) ) ;also called from optimizer pattern (DEFUN MA-REGISTERP (SLOT) (SYMBOLP SLOT)) (DEFUN MA-OPERAND-REFS-SLOT (SLOT OP) (COND ((NULL OP) NIL) ((EQUAL SLOT (CAR OP))))) (DEFUN MA-SAME-SEQUENCE (I1 I2) (EQ (MA-INST-SEQUENCE I1) (MA-INST-SEQUENCE I2))) (defun ma-not-immediately-before (i1 i2) (not (eq i1 (ma-inst-previous-inst i2)))) (DEFUN MA-OP1-SOURCE-INST (INST) (LET ((OP1 (first (MA-INST-OPs INST)))) (COND ((OR (ATOM OP1) (NOT (= (LENGTH (CDR OP1)) 1))) ;flush register spec (FERROR NIL "")) (T (MA-OPERAND-SOURCE (CADR OP1)))))) (DEFUN MA-OPs-SOURCE-INST (INST nth) (LET ((OP (nth nth (MA-INST-OPs INST)))) (COND ((OR (ATOM OP) (NOT (= (LENGTH (CDR OP)) 1))) ;flush register spec (FERROR NIL "")) (T (MA-OPERAND-SOURCE (CADR OP)))))) (DEFUN MA-OP1-SOURCE-INST-LIST (INST) (LET ((OP1 (first (MA-INST-OPs INST))) ANS) (COND ((ATOM OP1) (FERROR NIL "")) (T (DOLIST (OP (CDR OP1)) ;flush register spec. (SETQ ANS (CONS (MA-OPERAND-SOURCE OP) ANS))) (NREVERSE ANS))))) (DEFUN MA-PRECEEDING-INSTS-LIST (INST) (IF (MA-INST-CHANGED INST) (MA-OPT-RECYCLE-SEQ)) (LET* ((BS (MA-INST-BEFORE-STATE INST)) (PS (MA-STATE-PRECEEDING-STATES BS))) (MAPCAR (FUNCTION (LAMBDA (X) (IF (MA-INST-CHANGED (MA-STATE-INST X)) (MA-OPT-RECYCLE-SEQ)) (MA-STATE-INST X))) PS))) (DEFUN MA-FOLLOWING-INSTS-LIST (INST) (IF (MA-INST-CHANGED INST) (MA-OPT-RECYCLE-SEQ)) (LET* ((AS (MA-INST-AFTER-STATE INST)) (FS (MA-STATE-FOLLOWING-STATES AS))) (MAPCAR (FUNCTION (LAMBDA (X) (IF (MA-INST-CHANGED (MA-STATE-INST X)) (MA-OPT-RECYCLE-SEQ)) (MA-STATE-INST X))) FS))) (DEFUN MA-OPERAND-ONE-USE-P (OP) (= (LENGTH (MA-OPERAND-USES OP)) 1)) (DEFUN MA-ONE-AND-ONLY-USE-P (OL) (AND OL (NULL (CDR OL)) (MA-OPERAND-ONE-USE-P (CAR OL)))) (defun ma-pullable-arg-p (op &aux source-inst source-inst-code) ;TRUE if this operand represents an argument which can be "pulled". To be pullable, ; arg must be one-and-only-use-p, and also "made" by a single MOVE instruction, ; which references its "source". A MOVE xx, T after a subroutine call will NOT do. (and op (null (cdr op)) (ma-operand-one-use-p (car op)) (SETQ SOURCE-INST (MA-OPERAND-SOURCE (CAR OP))) (NULL (MA-INST-CHANGED SOURCE-INST)) (CONSP (SETQ SOURCE-INST-CODE (MA-INST-CODE SOURCE-INST))) (EQ (CAR SOURCE-INST-CODE) 'MOVE) (NULL (ASSQ 'BYTE-SPEC (FOURTH SOURCE-INST-CODE))) ;no byte specifier (consp (third source-inst-code)) (memq (car (third source-inst-code)) '(arg local special constant quote)))) (DEFUN MA-OPERAND-MOVE-OF-FIX-P (OP PATH &AUX SOURCE-INST SOURCE-INST-CODE SOURCE-INST-OP1) (OR (EQ (MA-OPERAND-TYPE OP) 'DTP-FIX) (AND (SETQ SOURCE-INST (MA-OPERAND-SOURCE OP)) (NULL (MA-INST-CHANGED SOURCE-INST)) (CONSP (SETQ SOURCE-INST-CODE (MA-INST-CODE SOURCE-INST))) (EQ (CAR SOURCE-INST-CODE) 'MOVE) (NULL (ASSQ 'BYTE-SPEC (FOURTH SOURCE-INST-CODE))) ;no byte specifier (SETQ SOURCE-INST-OP1 (CDR (first (MA-INST-OPS SOURCE-INST)))) (NOT (MEMQ SOURCE-INST-OP1 PATH)) ;avoid infinite loop in degenerate case (NULL (DOLIST (OP SOURCE-INST-OP1) (COND ((NULL (MA-OPERAND-MOVE-OF-FIX-P OP (CONS OP PATH))) (RETURN T)))))))) ;if any one not a fix, it isnt (defun ma-operand-move-of-fixnum-constant-p (op &AUX SOURCE-INST SOURCE-INST-CODE) (or (ma-fixnum-constantp (ma-operand-name op)) (AND (SETQ SOURCE-INST (MA-OPERAND-SOURCE OP)) (NULL (MA-INST-CHANGED SOURCE-INST)) (CONSP (SETQ SOURCE-INST-CODE (MA-INST-CODE SOURCE-INST))) (EQ (CAR SOURCE-INST-CODE) 'MOVE) (NULL (ASSQ 'BYTE-SPEC (FOURTH SOURCE-INST-CODE))) ;no byte specifier (ma-fixnum-constantp (third source-inst-code)) ))) (defun ma-operand-move-of-stack-var-p (op &aux source-inst source-inst-code) (format t "~%move-of-stack-var-p ~s" op) (and (setq source-inst (ma-operand-source op)) (null (ma-inst-changed source-inst)) (CONSP (SETQ SOURCE-INST-CODE (MA-INST-CODE SOURCE-INST))) (EQ (CAR SOURCE-INST-CODE) 'MOVE) (NULL (ASSQ 'BYTE-SPEC (FOURTH SOURCE-INST-CODE))) ;no byte specifier (consp (third source-inst-code)) (memq (car (third source-inst-code)) '(arg local)))) ;return nil if more than one. (DEFUN MA-OPT-PRECEEDING-INST (INST) (LET* ((BS (MA-INST-BEFORE-STATE INST)) (PS (MA-STATE-PRECEEDING-STATES BS))) (AND (NULL (MA-INST-CHANGED INST)) (NULL (CDR PS)) ;just one preceeding state (LET* ((PRECEEDING-STATE (CAR PS)) (PRECEEDING-INST (MA-STATE-INST PRECEEDING-STATE))) (AND (NULL (MA-INST-CHANGED PRECEEDING-INST)) PRECEEDING-INST))))) (DEFUN MA-OPT-FOLLOWING-INST (INST) (LET* ((AS (MA-INST-AFTER-STATE INST)) (FS (MA-STATE-FOLLOWING-STATES AS))) (AND (NULL (MA-INST-CHANGED INST)) (NULL (CDR FS)) (LET* ((FOLLOWING-STATE (CAR FS)) (FOLLOWING-INST (MA-STATE-INST FOLLOWING-STATE))) (AND (NULL (MA-INST-CHANGED FOLLOWING-INST)) FOLLOWING-INST))))) (DEFUN MA-OPT-IS-A-FOLLOWER (INST BEFORE-INST) (LET* ((AS (MA-INST-AFTER-STATE BEFORE-INST)) (FS (MA-STATE-FOLLOWING-STATES AS))) (AND (NULL (MA-INST-CHANGED INST)) (DOLIST (F FS) (COND ((EQ INST (MA-STATE-INST F)) (RETURN T))))))) (DEFUN MA-OPT-ONLY-PRECEEDER (BEFORE-INST INST) (LET* ((BS (MA-INST-BEFORE-STATE INST)) (PS (MA-STATE-PRECEEDING-STATES BS))) (AND (NULL (MA-INST-CHANGED INST)) (NULL (CDR PS)) (EQ BEFORE-INST (MA-STATE-INST (CAR PS)))))) ;return nil if not defined. (DEFUN MA-OPT-OTHER-FOLLOWING-INST (INST NOT-INST) (LET* ((AS (MA-INST-AFTER-STATE INST)) (FS (MA-STATE-FOLLOWING-STATES AS))) (AND (NULL (MA-INST-CHANGED INST)) (NULL (MA-INST-CHANGED NOT-INST)) (NULL (CDDR FS)) ;two following states (LET* ((FS1 (CAR FS)) (FI1 (MA-STATE-INST FS1)) (FS2 (CADR FS)) (FI2 (MA-STATE-INST FS2))) (AND (NULL (MA-INST-CHANGED FI1)) (NULL (MA-INST-CHANGED FI2)) (PROG2 (IF (NOT (OR (EQ FI1 NOT-INST) (EQ FI2 NOT-INST))) (FERROR NIL "not inst not one of choices")) (IF (EQ FI1 NOT-INST) FI2 FI1))))))) (DEFUN MA-OPT-APPLY-INST (ARG PC) (AND (NULL (MA-INST-CHANGED *INST*)) (MA-OPT-APPLY ARG PC))) (DEFUN MA-OPT-APPLY (ARG PC) (LEXPR-FUNCALL (CAR PC) ARG (CDR PC))) (DEFUN MA-OPT-SYMEVAL (SYM) (COND ((EQ SYM '*INST*) *INST*) ;special frob (T (CDR (ASSOC SYM *ALIST*))))) (defun ma-add-byte-spec-from-op1 (old-if) (let* ((op1 (car (cdr (first (ma-inst-ops *inst*))))) (source-inst (ma-operand-source op1)) (source-inst-code (ma-inst-code source-inst)) (source-constant (third source-inst-code)) (constant-value (ma-fixnum-constant source-constant)) (bits (ldb 0006 constant-value)) (over (ldb 0606 constant-value))) (cons `(byte-spec (dtp-fix ,bits ,over)) old-if)) ) (DEFUN MA-OPT-MATCH-WD (CODE P) (let ((val (PROG () (COND ((ATOM P) (RETURN (EQ P CODE)))) L (COND ((NULL P) (RETURN (NULL CODE))) ((ATOM P) ;dotted rest variable (RETURN (MATCH-OPT-MATCH-VAR CODE P NIL))) ((AND (CONSP P) (EQ (CAR P) '==)) (RETURN (MATCH-OPT-MATCH-VAR CODE (CADR P) (CDDR P)))) ((ATOM CODE) (RETURN NIL))) (COND ((NULL (MA-OPT-MATCH-WD (CAR CODE) (CAR P))) (RETURN NIL))) (SETQ CODE (CDR CODE) P (CDR P)) (GO L)))) (if (and (null val) *ma-opt-trace-match*) (format t "~%Pattern failing: ~s : ~s" code p)) val) ) (DEFUN MATCH-OPT-MATCH-VAR (CODE VAR RESTRICTIONS) (LET ((SYM (MA-OPT-EXPAND-CHAIN-VAR VAR)) TEM) (COND ((EQ SYM '?) T) ((SETQ TEM (ASSOC SYM *ALIST*)) (EQUAL (CDR TEM) CODE)) ((AND RESTRICTIONS (DOLIST (E RESTRICTIONS) (COND ((NULL (APPLY (CAR E) (CONS CODE (CDR E)))) (RETURN T))))) NIL) ;predicate not true. (T (COND ((MEMBER SYM *MA-OPT-TRACE-VARS*) (FORMAT T "~%Assigning ~s: ~s" SYM CODE))) (SETQ *ALIST* (CONS (CONS SYM CODE) *ALIST*)) T)))) (DEFUN MA-OPT-EXPAND-CHAIN-VAR (VAR) (PROG (NC) (COND ((MEMQ VAR '(? *INST*)) (RETURN VAR))) (SETQ NC *NAMECHAIN*) L (COND ((SYMBOLP VAR)) ((EQ (CAR VAR) '=) (SETQ NC NIL VAR (CADR VAR)) (GO L)) ((EQ (CAR VAR) '*) (SETQ NC (CDR NC) VAR (CADR VAR)) (GO L))) (COND ((AND (SYMBOLP VAR) (NULL NC)) (RETURN VAR)) (T (RETURN (CONS VAR (MAPCAR (FUNCTION MA-OPT-SYMEVAL) NC))))))) (DEFUN MA-OPT-ACT (INSTS ACTIONS *ALIST*) (LET ((*MA-OPT-TRACE-ACTS* *MA-OPT-TRACE-ACTS*)) ;(ma-check-sequence-members) (DO ((inst (car insts) (ma-inst-next-inst inst)) (A ACTIONS (CDR A))) ((NULL A) ;CALLER SHOULD DO A THROW TO 'OPT-SEQUENCE ; BEFORE TURNING LOOSE THE MAIN THING AGAIN IF (MA-SEQ-CHANGED *SEQ*) (cond (*ma-opt-trace-acts* (format t "~% Leaving MA-OPT-ACT, seq is ~s" (ma-elem-members *seq*)))) ;(ma-check-sequence-members) ) (cond ((act-includes-insert-p (car a)) ;(ma-check-sequence-members) (let ((new-inst (ma-initialize-inst)) (one-before-this (ma-inst-previous-inst inst)) (one-after-this inst)) ;insert new-inst before inst. (setf (ma-inst-previous-inst new-inst) one-before-this) (setf (ma-inst-next-inst new-inst) one-after-this) (setf (ma-inst-previous-inst one-after-this) new-inst) (setf (ma-inst-next-inst one-before-this) new-inst) (setf (ma-inst-sequence new-inst) *seq*) (setf (ma-elem-members *seq*) (insert-before (if (eq (ma-inst-sequence inst) *seq*) inst nil) new-inst (ma-elem-members *seq*))) (IF *MA-OPT-TRACE-ACTS* (FORMAT T "~% Inserting ~s before ~s, seq now ~s" new-inst inst (ma-elem-members *seq*))) (setq inst new-inst) ;(ma-check-sequence-members) ))) (cond ((not (eq *seq* (ma-inst-sequence inst))) (ferror nil "Ran off sequence boundary!"))) (MA-OPT-ACT-ON INST (CAR A) NIL)))) (defun act-includes-insert-p (act-list) (dolist (act act-list) (if (eq (car act) 'insert) (return t)))) (DEFUN MA-OPT-ACT-ON (*INST* ACT-LIST *NAMECHAIN*) ;(FORMAT T "~%*INST* ~S, ACT-LIST ~S" *INST* ACT-LIST) (PROG (ACT FCTN ICODE) (COND (*MA-OPT-TRACE-ACTS* (FORMAT T "~%Enter ACT ~S, namechain ~S, ==>" *INST* *NAMECHAIN*))) (SETQ ICODE (MA-INST-CODE *INST*)) L (COND ((NULL ACT-LIST) (COND (*MA-OPT-TRACE-ACTS* (FORMAT T "~% ~S ==> ~S, namechain ~S" ICODE (MA-INST-CODE *INST*) *NAMECHAIN*))) (RETURN *INST*))) ;can be different from arg in case of PUT-INSERT (SETQ ACT (CAR ACT-LIST)) (IF (NULL (SETQ FCTN (GET (CAR ACT) 'MA-OPT-ACT))) (FERROR NIL "~%unknown action") (FUNCALL FCTN (CDR ACT))) (SETQ ACT-LIST (CDR ACT-LIST)) (GO L))) (DEFUN (FLUSH MA-OPT-ACT) (ACT) ACT (MA-OPT-FLUSH) ) (DEFUN MA-OPT-FLUSH NIL ;(ma-check-sequence-members) (if *ma-opt-trace-acts* (format t "~%About to flush inst ~s" *inst*)) (SETF (MA-INST-EXPANSION *INST*) (MA-INST-CODE *INST*)) ;save for debugging (SETF (MA-INST-CODE *INST*) NIL) (SETF (MA-INST-CHANGED *INST*) T) (MA-FLUSH-INST *INST*) ;flush it. (SETQ *MA-OPT-FLAG* T) (setf (ma-elem-members *seq*) (remq *inst* (ma-elem-members *seq*))) (SETF (MA-SEQ-CHANGED (MA-INST-SEQUENCE *INST*)) T) (if *ma-opt-trace-acts* (format t "~%Sequence now is ~s" (ma-elem-members *seq*))) ;(ma-check-sequence-members) ) (DEFUN (PUT MA-OPT-ACT) (ACT) (SETF (MA-INST-CODE *INST*) (MA-OPT-SUBS (CAR ACT))) (SETF (MA-INST-CHANGED *INST*) T) (SETQ *MA-OPT-FLAG* T) (SETF (MA-SEQ-CHANGED (MA-INST-SEQUENCE *INST*)) T)) (defun (insert ma-opt-act) (act) act nil) ;dummy, really interpreted at MA-OPT-ACT level ;this should not be used now. (defun (put-insert ma-opt-act) (act) (let ((new-inst (ma-initialize-inst)) (one-before-this (ma-inst-previous-inst *inst*))) (setf (ma-inst-previous-inst new-inst) one-before-this) (setf (ma-inst-next-inst new-inst) *inst*) (setf (ma-inst-previous-inst *inst*) new-inst) (setf (ma-inst-next-inst one-before-this) new-inst) (setf (ma-inst-sequence new-inst) *seq*) (setf (ma-elem-members *seq*) (insert-before *inst* new-inst (ma-elem-members *seq*))) (setq *inst* new-inst) (funcall (get 'put 'ma-opt-act) act) )) (defun insert-before (item-before new-item list) (cond ((null list) (if (null item-before) (list new-item) (ferror "unable to insert before"))) ((eq item-before (car list)) (cons new-item list)) (t (cons (car list) (insert-before item-before new-item (cdr list)))))) (DEFUN (PUT-INST MA-OPT-ACT) (ACT) (MA-OPT-ACT-ON (MA-OPT-SUBS (CAR ACT)) (CADR ACT) *NAMECHAIN*)) (DEFUN MA-OPT-SUBS (PAT) (PROG (V P) (COND ((NULL PAT) (RETURN NIL)) ((ATOM PAT) (RETURN PAT)) ((EQ (CAR PAT) '==) (cond ((or (symbolp (cadr pat)) (and (listp (cadr pat)) (eq (car (cadr pat)) '*))) ;kludge for namechains (RETURN (MA-OPT-SUBS-VAR (CADR PAT) (CDDR PAT)))) (t (return (apply (car (cadr pat)) (ma-opt-subs (cdr (cadr pat)))))))) ((EQ (CAR PAT) 'QUOTE) (RETURN PAT))) (SETQ P (LOCF V)) L (COND ((NULL PAT) (RETURN V)) ((SYMBOLP PAT) ;dotted rest var. (RPLACD P (MA-OPT-SUBS-VAR PAT NIL)) (RETURN V))) (RPLACD P (SETQ P (LIST (MA-OPT-SUBS (CAR PAT))))) (SETQ PAT (CDR PAT)) (GO L))) (DEFUN MA-OPT-SUBS-VAR (VAR ALTERATION) (LET* ((SYM (MA-OPT-EXPAND-CHAIN-VAR VAR)) (VAL (MA-OPT-SYMEVAL SYM))) (IF ALTERATION (SETQ VAL (APPLY (CAAR ALTERATION) ;call function to alter value (CONS VAL (CDAR ALTERATION))))) VAL)) (DEFUN MA-INVERT (V 2-LIST) (COND ((EQ V (CAR 2-LIST)) (CADR 2-LIST)) ((EQ V (CADR 2-LIST)) (CAR 2-LIST)) (T (FERROR NIL "")))) (defun ma-no-byte-spec (x) (null (assq 'byte-spec x))) (defun ma-assq (v a-list) (let ((ans (assq v a-list))) (if (null ans) (ferror nil "") (cdr ans)))) (defun ma-merge-info (i1 i2) (dolist (i i1) (pushnew i i2 :test 'member)) i2) (defprop xtnot (t) registers-clobbered) (defprop not (t j) registers-clobbered) (defprop array-decode-1-dispatch t registers-clobbered) ;may clobber all it doesnt set up (defprop array-type-ref-dispatch (registers-preserved (a b e s) operand-returned t) ;make an operand for my result comming ;back in M-T. ma-clobberage-property) ;check below for refs to complex arrays, etc. (defprop array-type-store-dispatch-pushj (a b e s t) registers-preserved)