7 "PEEPHOLE OPTIMIZER: IT WILL DO SEVERAL TYPES OF OPTIMIZATIONS ON THE
8 CODE OUTPUT BY THE COMPILER. THIS INCLUDES REMOVING UNREACHABLE CODE
9 REMOVE THE COPYING OF SIMILAR CODE AND OTHER MINOR OPTIMIZATIONS."
11 <SETG INSTRUCTION ,FORM>
19 <SETG SKIP-TBL ![4 5 6 7 0 1 2 3!]>
21 <SETG TEST-TBL ![2 3 0 1!]>
23 <MANIFEST SKIP-TBL TEST-TBL>
25 <NEWTYPE LNODE VECTOR '<VECTOR LIST LIST <OR FALSE TUPLE> ATOM>>
37 <SETG NULL-INST <CHTYPE () NULL>>
41 '<LIST <PRIMTYPE WORD> FIX <OR 'T FALSE> <OR FALSE LNODE>>>
51 <NEWTYPE SKIP-INS LIST '<LIST <PRIMTYPE WORD>
116 "PEEP STARTS BY BUILDING A CODE STRUCTURE WITH SKIPS AND JUMPS REPLACED BY THERE
117 EXPANDED INS-TYPES AND WITH JUMPS AND THIER LABELS LINKED UP WITH THE USE OF LNODES."
121 "AUX" QXD (MODLN (())) NNCOD (LABNUM 0) (NUMLABS 0) (NNUMLABS 0)
122 NLN (LN <LENGTH .COD>) XD QD (SLABS ()) (TOPCOD .COD)
124 #DECL ((XCOD) LIST (SLABS MODLN) <SPECIAL LIST> (LABNUM) <SPECIAL FIX>
125 (NLN LN) FIX (NUMLABS NNUMLABS) <SPECIAL FIX>)
126 <REPEAT TG-FND ((CPTR .COD) AT)
128 <COND (<EMPTY? .CPTR> <RETURN>)
129 (<OR <TYPE? <SET AT <1 .CPTR>> ATOM>
130 <AND <TYPE? .AT FORM>
131 <==? <1 .AT> INTERNAL-ENTRY!-OP!-PACKAGE>
133 <SET AT <PSEUDO? .AT>>>
134 <PUTREST <REST .MODLN <- <LENGTH .MODLN> 1>>
135 (<SET AT <CHTYPE [(.AT) () .CPTR .AT] LNODE>>)>
136 <SET NUMLABS <+ .NUMLABS 1>>
138 <AND <EMPTY? <SET CPTR <REST .CPTR>>>
140 <COND (<TYPE? <SET IN <1 .CPTR>> ATOM>
141 <PUT .AT ,LABLS-LN (.IN !<LABLS-LN .AT>)>
142 <SET NNUMLABS <+ .NNUMLABS 1>>
143 <PUT .CPTR 1 ,NULL-INST>)
145 (<SET CPTR <REST .CPTR>>)>>
146 <SET MODLN <REST .MODLN>>
148 <FUNCTION (RCOD "AUX" QD (INST <1 .RCOD>))
149 #DECL ((QD) <OR FALSE LNODE> (RCOD) TUPLE)
152 <SET INST <INSTYPE .INST>>
153 <COND (<TYPE? .INST JUMP-INS>
154 <SET XD <FIND-LAB <REST .INST 4>>>
155 <SET QD <COND (.XD <FIND-NOD .MODLN .XD>)>>
159 <PUT .INST ,WHERE-JMP .QD>
163 <ADDON (.RCOD) <JUMPS-LN .QD>>>)
164 (<SET QD <CHTYPE [(.XD) () <> .XD] LNODE>>
165 <SET MODLN (.QD !.MODLN)>
168 <COND (<AND <SET XD <NFIND-LAB .INST>>
169 <SET XD <FIND-NOD .MODLN .XD>>>
170 <SET INST <MUNG-LAB .INST <NAME-LN .XD>>>
171 <SET SLABS (.XD !.SLABS)>)>
172 <PUT .RCOD 1 .INST>)>)>>
174 <PROG REOPT ((NLABLS ()) (REDO <>))
175 #DECL ((NLABLS) <SPECIAL LIST> (REDO) <SPECIAL <OR STRING FALSE ATOM>>)
177 <FUNCTION (NCOD "AUX" QD (INST <1 .NCOD>) (NNCOD .NCOD))
178 #DECL ((NNCOD NCOD) TUPLE)
180 (<TYPE? .INST JUMP-INS>
181 <REPEAT (TMP AOJ-FLG NEWLAB)
182 <COND (<NOT <SET TMP <CODE-LN <WHERE-JMP .INST>>>> <RETURN>)>
183 <SET QD <NEXTS .TMP>>
185 (<AND <NOT <G? <INS-JMP .INST> ,LO-JMP2>>
186 <REPEAT ((NC .NNCOD))
187 <COND (<==? .NC .TOPCOD> <RETURN>)>
189 <COND (<NOT <TYPE? <1 .NC> ATOM NULL>>
190 <RETURN <NOT <SKIPPABLE <1 .NC>>>>)>>
191 <REPEAT ((NC .NNCOD))
192 <COND (<EMPTY? <SET NC <REST .NC>>> <RETURN <>>)
193 (<==? .TMP .NC> <RETURN>)
194 (<NOT <TYPE? <1 .NC> ATOM NULL>>
195 <RETURN <==? .NC .TMP>>)>>>
197 <PUT .NNCOD 1 ,NULL-INST>
198 <SET REDO "REMOVED JUMP CHAINING">
200 (<AND <TYPE? .QD JUMP-INS> <UNCON-JMP .QD>>
201 <COND (<NOT <AND <SET AOJ-FLG <G? <INS-JMP .QD> ,LO-JMP2>>
202 <OR <G? <INS-JMP .INST> ,LO-JMP2>
203 <NOT <UNCON-JMP .INST>>>>>
205 <SET NEWLAB <ADDON (.NNCOD) <JUMPS-LN <WHERE-JMP .QD>>>>
209 <SET INST <CHTYPE <SUBSTRUC .QD> JUMP-INS>>>)
211 <PUT .INST ,WHERE-JMP <WHERE-JMP .QD>>
212 <PUT <WHERE-JMP .QD> ,JUMPS-LN .NEWLAB>)>
213 <SET REDO "REMOVED JUMP CHAINING">)
218 <NOT <UNCON-JMP .INST>>
221 (<EMPTY? .NC> <RETURN <>>)
222 (<TYPE? <1 <SET NC <REST .NC>>> NULL>)
223 (<AND <TYPE? <1 <SET TEMP .NC>> JUMP-INS>
224 <==? <INS-JMP <1 .NC>> ,JRST1>>
225 <RETURN <==? <NEXTS <REST .NC> T>
226 <NEXTS <CODE-LN <WHERE-JMP .INST>> T>>>)
228 <NOT <SKIPPABLE <BACKS .NCOD .TOPCOD <> 1>>>>
230 <PUT .INST ,WHERE-JMP <WHERE-JMP <1 .TEMP>>>
232 <PUT .TEMP 1 ,NULL-INST>
233 <PUT <WHERE-JMP .INST>
235 <ADDON (.NCOD) <JUMPS-LN <WHERE-JMP .INST>>>>
236 <PUT .INST ,COND-JMP <NTH ,SKIP-TBL <+ <COND-JMP .INST> 1>>>
237 <SET REDO "OPTIMIZED CONDITIONAL JUMP/NON-COND JUMP">)>)
238 (<TYPE? .INST SKIP-INS>
240 <NOT <UNCON-SKP .INST>>
243 (<EMPTY? <SET NCOD <REST .NCOD>>> <RETURN>)
244 (<AND <OR <AND <TYPE? <SET QD <1 .NCOD>> SKIP-INS>
247 <NOT <TYPE? <BACKS .NCOD .TOPCOD <> 2>
249 <AND <TYPE? .QD JUMP-INS>
250 <==? <INS-JMP .QD> ,JRST1>
251 <==? <REST <CODE-LN <WHERE-JMP .QD>>>
252 <NEXTS <REST .NCOD> T 2>>
253 <NOT <TYPE? <BACKS .NCOD .TOPCOD <> 2> SKIP-INS>>
254 <DEL-JUMP-LN .NCOD>>>
255 <PUT <BACKS .NCOD .TOPCOD T 1> 1 ,NULL-INST>
258 <SET REDO "SKIP-CHAIN OPTIMIZATION">
260 (<NOT <TYPE? .QD NULL>> <RETURN>)>>>
261 <AND <TYPE? <SET XD <1 .NCOD>> JUMP-INS>
262 <NOT <TYPE? <BACKS .NCOD .TOPCOD <> 2> SKIP-INS>>
264 <SET QXD <WHERE-JMP .XD>>
265 <TYPE? <NEXTS <REST .NCOD>> SKIP-INS>
266 <TYPE? <SET XD <NEXTS <REST .NCOD> <> 2>> JUMP-INS>
268 <==? <WHERE-JMP .XD> .QXD>
270 <PUT .NCOD 1 ,NULL-INST>
272 <SET REDO "OPTIMIZING CONDITIONAL JUMPS">>)
275 <OR <==? <1 .INST> `ADDI > <==? <1 .INST> `SUBI >>
276 <==? <LENGTH .INST> 3>
279 <COND (<EMPTY? .NCOD> <RETURN>)>
280 <SET NCOD <REST .NCOD>>
282 (<TYPE? <SET QD <1 .NCOD>> JUMP-INS>
284 (<OR <==? <INS-JMP .QD> ,JRST1>
285 <AND <G=? <INS-JMP .QD> ,LOW-JMP1>
286 <L=? <INS-JMP .QD> ,HI-JMP1>
288 <==? <2 .INST> <5 .QD>>>>
289 <PUT <BACK .NCOD> 1 ,NULL-INST>
297 (<==? <INS-JMP .QD> ,JRST1>
298 <COND (<==? <1 .INST> `ADDI > `AOJA ) (ELSE `SOJA )>)
299 (<==? <1 .INST> `ADDI >
302 <+ <CHTYPE <INS-JMP .QD> FIX> 16>>
303 OPCODE!-OP!-PACKAGE>)
307 <+ <CHTYPE <INS-JMP .QD> FIX> 32>>
308 OPCODE!-OP!-PACKAGE>)>
310 <OR <AND <WHERE-JMP .QD> <NAME-LN <WHERE-JMP .QD>>>
311 <NFIND-LAB <REST .QD 4>>>>>>>
312 <PUT .TEM ,WHERE-JMP <WHERE-JMP .QD>>
313 <SET REDO "ADDI OR SUBI FOLLOWED BY A JUMP">
320 <AND <==? .NCOD .TOPCOD> <RETURN>>
321 <SET NCOD <BACK .NCOD>>
323 (<TYPE? <SET QD <1 .NCOD>> NULL>)
325 <SET QD <FIND-NOD .MODLN .QD>>
329 <COND (<NOT <OR <TYPE? <1 .X> NULL>
330 <==? <INS-JMP <1 .X>> ,JRST1>>>
334 <SET REDO "JUMP TO AN ADDI OR SUBI">
335 <PUT .NCOD 1 <1 .NNCOD>>
336 <PUT .NNCOD 1 <NAME-LN .QD>>
340 <COND (<==? <1 .INST> `ADDI > `AOJA )
345 <PUT <INSTYPE <INSTRUCTION
346 .IT <2 .INST> <NAME-LN .QD>>>
352 (<AND <TYPE? .INST FORM>
353 <==? <1 .INST> DEALLOCATE>
354 <TYPE? <SET XD <1 <REST .NCOD>>> FORM>
355 <==? <1 .XD> DEALLOCATE>>
356 <PUT .NCOD 1 ,NULL-INST>
357 <PUT .XD 2 (!<2 .XD> !<2 .INST>)>)>>
360 <FUNCTION (LN "AUX" (COMPS <JUMPS-LN .LN>))
363 (<NOT <EMPTY? .COMPS>>
368 <COND (<AND <UNCON-JMP <1 .CMP>>
369 <==? <INS-JMP <1 .CMP>> ,JRST1>>
373 <AND <CODE-LN .LN> <CROSS-OPT .TOPCOD <CODE-LN .LN> !.COMPS>>
374 <SET COMPS <JUMPS-LN .LN>>
379 <COND (<AND <UNCON-JMP <1 .CMP>>
380 <==? <INS-JMP <1 .CMP>> ,JRST1>>
387 <CROSS-OPT .TOPCOD <1 .CMP> !<REST .CMP>>>
390 <SET MODLN <CLEAN-IT-UP .MODLN>>
392 <FUNCTION (NCOD "AUX" (INST <1 .NCOD>))
395 (<AND <OR <AND <TYPE? .INST JUMP-INS> <UNCON-JMP .INST>>
396 <AND <TYPE? .INST FORM>
397 <==? <1 .INST> `JRST >
398 <NOT <=? <2 .INST> '.HERE!-OP!-PACKAGE>>>>
399 <REPEAT ((NC <BACK .NCOD>))
400 <COND (<TYPE? <1 .NC> ATOM NULL>
401 <COND (<==? .NC .TOPCOD> <RETURN T>)
402 (<SET NC <BACK .NC>>)>)
403 (<RETURN <NOT <SKIPPABLE <1 .NC>>>>)>>>
406 (<EMPTY? <SET NCOD <REST .NCOD>>> <RETURN>)
408 <TYPE? <SET QD <1 .NCOD>> ATOM>
409 <AND <TYPE? .QD FORM>
410 <OR <==? <1 .QD> INTERNAL-ENTRY!-OP!-PACKAGE>
412 <AND <TYPE? <1 .QD> ATOM>
413 <OR <FIND-NOD .MODLN <1 .QD>>
414 <NOT <GASSIGNED? <1 .QD>>>>>>>
418 <COND (<AND <NOT <EMPTY? <JUMPS-LN .LN>>>
419 <==? <CODE-LN .LN> .NCOD>>
425 <COND (<TYPE? <1 .NCOD> JUMP-INS> <DEL-JUMP-LN .NCOD>)>
426 <PUT .NCOD 1 ,NULL-INST>
427 <SET REDO "FLUSH UNREACHABLE CODE">)>>)>>
429 <SET MODLN <FLUSH-LABELS .MODLN>>
430 <REPEAT FFY ((PTR1 <REST .COD <- <LENGTH .COD> 1>>)
431 (PTR2 <REST .COD <- <LENGTH .COD> 1>>) XD)
432 #DECL ((PTR2 PTR1) TUPLE)
434 <FUNCTION (X) <COND (<==? <2 .X> .PTR1> <PUT .X 2 .PTR2>)>>
436 <COND (<TYPE? <SET XD <1 .PTR1>> NULL>)
438 <COND (<TYPE? .XD ATOM>
439 <AND <SET XD <FIND-NOD .MODLN .XD>>
440 <PUT .XD ,CODE-LN .PTR2>>)
441 (<TYPE? .XD JUMP-INS>
442 <PUT <MEMQ .PTR1 <JUMPS-LN <WHERE-JMP .XD>>>
445 <SET PTR2 <BACK .PTR2>>)>
446 <COND (<==? .PTR1 .TOPCOD>
448 <COND (<==? .PTR2 .TOPCOD>
449 <PUT .PTR2 1 ,NULL-INST>
451 (<PUT .PTR2 1 ,NULL-INST>
452 <SET PTR2 <BACK .PTR2>>)>>)
453 (<SET PTR1 <BACK .PTR1>>)>>
454 <REPEAT (P1 (PTR1 .COD) (PTR2 .COD))
455 <COND (<EMPTY? .PTR1>
456 <MAPR <> <FUNCTION (X) <PUT .X 1 ,NULL-INST>> .PTR2>
460 <COND (<==? <2 .X> .PTR1>
461 <SET NNUMLABS <- .NNUMLABS 1>>
463 <PUT <FIND-NOD .MODLN <1 .X>> ,CODE-LN .PTR2>
464 <SET PTR2 <REST .PTR2>>)>>
466 <COND (<TYPE? <SET P1 <1 .PTR1>> NULL>)
468 <COND (<NOT .REDO> <PUT .PTR2 1 <INSFIX .P1>>)
470 <COND (<TYPE? .P1 ATOM>
471 <AND <SET XD <FIND-NOD .MODLN .P1>>
472 <PUT .XD ,CODE-LN .PTR2>>)
473 (<TYPE? .P1 JUMP-INS>
474 <PUT <MEMQ .PTR1 <JUMPS-LN <WHERE-JMP .P1>>>
477 <SET PTR2 <REST .PTR2>>)>
478 <SET PTR1 <REST .PTR1>>>
479 <COND (.REDO <SET NLABLS ()> <SET REDO <>> <AGAIN .REOPT>)
483 <COND (<EMPTY? .COD> <RETURN .N>)
484 (<TYPE? <1 .COD> NULL>)
486 <PUT .XCOD 1 <1 .COD>>
488 <SET XCOD <REST .XCOD>>
490 <SET COD <REST .COD>>>>
491 <OR <EMPTY? .NNCOD> <PUTREST .NNCOD ()>>)>>
492 <COND (<AND <ASSIGNED? PEEP> .PEEP>
493 <PEEP-PRINT .LN .NLN .NUMLABS .NNUMLABS>)>>
497 <DEFINE INSTYPE (INST "AUX" AT QX QY)
498 #DECL ((QX) <PRIMTYPE WORD>)
500 (<AND <TYPE? .INST FORM>
501 <TYPE? <SET AT <1 .INST>> OPCODE!-OP!-PACKAGE>
502 <SET QX <CHTYPE <GETBITS .AT <BITS 9 27>> FIX>>
504 <AND <G=? .QX ,LOW-SKP1> <L=? .QX ,HI-JMP2>>>>
505 <SET QY <CHTYPE <GETBITS .QX <BITS 6 3>> FIX>>
506 <COND (<AND <OR <==? .QX ,JRST1> <AND <N==? .QY 24> <0? <MOD .QY 2>>>>
507 <NOT <0? <SET QY <CHTYPE <GETBITS .QX <BITS 3>> FIX>>>>>
508 <CHTYPE (.QX .QY <==? .QY 4> <> !<REST .INST>) JUMP-INS>)
509 (<NOT <0? <SET QY <CHTYPE <GETBITS .QX <BITS 3>> FIX>>>>
510 <CHTYPE (.QX .QY <> <==? .QY 4> !<REST .INST>) SKIP-INS>)
515 <NOT <0? <SET QY <CHTYPE <GETBITS .QX <BITS 2 1>> FIX>>>>>
516 <CHTYPE (.QX .QY T <==? .QY 2> !<REST <CHTYPE .INST LIST>>)
520 <DEFINE NFIND-LAB (INST)
521 <COND (<TYPE? .INST ATOM> .INST)
525 <COND (<SET X <NFIND-LAB .X>> <MAPLEAVE .X>)>>
528 <DEFINE FIND-NOD (MD AT)
529 #DECL ((MD) LIST (AT) ATOM)
533 <COND (<MEMQ .AT <LABLS-LN .X>> <MAPLEAVE .X>)>>
536 <DEFINE INSFIX (X "AUX" XD)
540 <CHTYPE <PUTBITS #WORD *000000000000*
542 <CHTYPE <ORB <ANDB <INS-JMP .X> 504> <COND-JMP .X>> FIX>>
544 !<COND (<==? <LENGTH <SET XD <REST .X 4>>> 2>
545 (<1 .XD> <NAME-LN <WHERE-JMP .X>>))
546 (ELSE (<NAME-LN <WHERE-JMP .X>>))>>)
550 <CHTYPE <PUTBITS #WORD *000000000000*
552 <CHTYPE <ORB <ANDB <INS-SKP .X> 505>
555 OPCODE!-OP!-PACKAGE>)
557 <CHTYPE <PUTBITS #WORD *000000000000*
559 <CHTYPE <ORB <ANDB <INS-SKP .X> 504>
562 OPCODE!-OP!-PACKAGE>)>
567 #DECL ((X) STRUCTURED)
570 <COND (<TYPE? .X ATOM>) (ELSE <PRINC " ">)>
575 <DEFINE CROSS-OPT (TOPCOD NCOD "TUPLE" COMPS "AUX" NEWLN)
576 #DECL ((TOPCOD NCOD) TUPLE (COMPS) TUPLE (MODLN NLABS) LIST)
577 <REPEAT (QD LABL (CNT 0) (NEEDLABEL T))
578 #DECL ((CNT) FIX (COMPS) TUPLE)
579 <AND <==? .NCOD .TOPCOD> <RETURN>>
580 <SET NCOD <BACK .NCOD>>
582 <FUNCTION (XD "AUX" (XR <1 .XD>))
583 #DECL ((XD) TUPLE (XR) <OR TUPLE NULL>)
584 <COND (<TYPE? .XR NULL>)
588 <PUT .XD 1 <SET XR <BACK .XR>>>
590 <COND (<TYPE? <1 .XR> NULL>) (<RETURN>)>>)>>
592 <COND (<0? .CNT> <RETURN>) (<SET CNT 0>)>
593 <COND (.NEEDLABEL <SET LABL <MAKE:LABEL>> <SET NEEDLABEL <>>)>
594 <SET NEWLN <CHTYPE [(.LABL) () .NCOD .LABL] LNODE>>
596 <COND (<OR <SKIPPABLE <1 <BACK .NCOD>>> <SKIPPABLE <1 .NCOD>>> <RETURN>)>
598 <FUNCTION (NPCOD "AUX" (NNCOD <1 .NPCOD>) ITEM)
599 #DECL ((NPCOD) TUPLE (NNCOD) <OR NULL TUPLE>)
600 <COND (<TYPE? .NNCOD NULL>)
601 (<SET ITEM <1 .NNCOD>>
602 <COND (<AND <N==? .NCOD .NNCOD> <=? .ITEM .QD>>
604 <COND (<TYPE? <1 .NNCOD> JUMP-INS>
605 <DEL-JUMP-LN .NNCOD>)>
606 <COND (<==? .NCOD <NEXTS <REST .NNCOD> T>>
607 <PUT .NNCOD 1 ,NULL-INST>)
611 <CHTYPE (,JRST1 4 T .NEWLN .LABL)
615 (.NNCOD !<JUMPS-LN .NEWLN>)>)>
616 <SET REDO "CROSS-OPTIMIZATION">
618 (<PUT .NPCOD 1 ,NULL-INST>)>)>>
620 <COND (<NOT <0? .CNT>>
621 <SET NLABLS ((.LABL .NCOD) !.NLABLS)>
622 <SET MODLN (.NEWLN !.MODLN)>)>
623 <COND (<0? .CNT> <RETURN>) (<SET CNT 0>)>>>
625 <DEFINE FF (X) #DECL ((X) STRUCTURED) <MAPF <> ,& .X> <CRLF>>
627 "ROUTINE TO DETERMINE WHETHER AN INSTRUCTION CAN SKIP"
629 <DEFINE HACK-PRINT (X) <PRIN1 <INSFIX .X>>>
631 <DEFINE SKIPPABLE (INST)
632 <OR <TYPE? .INST SKIP-INS>
633 <AND <TYPE? .INST FORM>
634 <OR <==? <1 .INST> `XCT >
635 <==? <1 .INST> `PUSHJ >
636 <AND <G=? <LENGTH .INST> 2>
637 <MEMBER '.HERE!-OP!-PACKAGE .INST>>>>>>
639 "ROUTINE TO DELETE A JUMP-LN FROM AN LNODE."
641 <DEFINE DEL-JUMP-LN (COD "AUX" XD QD (JMP <1 .COD>))
642 #DECL ((JMP) JUMP-INS (COD) TUPLE (XD QD) <OR FALSE LIST>)
643 <COND (<SET XD <MEMQ .COD
644 <SET QD <JUMPS-LN <CHTYPE <WHERE-JMP .JMP>
646 <COND (<==? .QD .XD> <PUT <CHTYPE <WHERE-JMP .JMP> LNODE>
647 ,JUMPS-LN <REST .XD>>)
649 <PUTREST <REST .QD <- <LENGTH .QD> <LENGTH .XD> 1>>
653 <DEFINE CHANGE-COND (INST)
654 #DECL ((INST) SKIP-INS)
657 <COND (<TEST-SKP .INST> <NTH ,TEST-TBL <+ <COND-SKP .INST> 1>>)
658 (<NTH ,SKIP-TBL <+ <COND-SKP .INST> 1>>)>>>
660 <DEFINE MAKE:LABEL ("AUX" XX) #DECL ((LABNUM) FIX)
662 <STRING "OPT" <UNPARSE <SET LABNUM <+ .LABNUM 1>>>>>
664 <INSERT .XX <GET TMP OBLIST>>>>
666 <DEFINE NEXTS (XX "OPTIONAL" (XT <>) (NN 1) "AUX" XR)
667 #DECL ((XX) TUPLE (NN) FIX)
669 <COND (<TYPE? <SET XR <1 .XX>> NULL ATOM>)
670 (<0? <SET NN <- .NN 1>>> <RETURN .XR>)>
671 <AND <EMPTY? <SET XX <REST .XX>>>
674 <COND (.XT .XX) (ELSE .XR)>>
676 <DEFINE BACKS (XX TOPCOD "OPTIONAL" (XT <>) (NN 1) "AUX" XR)
677 #DECL ((XX TOPCOD) TUPLE (NN) FIX)
679 <AND <==? <SET XX <BACK .XX>> .TOPCOD> <RETURN .XR>>
680 <COND (<TYPE? <SET XR <1 .XX>> NULL ATOM>)
681 (<0? <SET NN <- .NN 1>>> <RETURN .XR>)>>
682 <COND (.XT .XX)(ELSE .XR)>>
685 <DEFINE ADDON (AD OB)
686 #DECL ((AD OB) <PRIMTYPE LIST>)
687 <COND (<EMPTY? .OB> .AD)
688 (ELSE <PUTREST <REST .OB <- <LENGTH .OB> 1>> .AD> .OB)>>
690 <DEFINE FIND-LAB (INST)
692 <FUNCTION (X) <COND (<TYPE? .X ATOM> <MAPLEAVE .X>)>>
696 #DECL ((VALUE) <OR ATOM FALSE>)
697 <AND <TYPE? .AT FORM>
698 <==? <1 .AT> PSEUDO!-OP!-PACKAGE>
700 <TYPE? <SET AT <2 .AT>> FORM>
703 <=? <3 .AT> '<ANDB 262143 <CHTYPE .HERE!-OP!-PACKAGE FIX>>>
706 <DEFINE MUNG-LAB (INST ATM)
707 <COND (<TYPE? .INST ATOM> .ATM)
711 <FUNCTION (IN "AUX" (OB <1 .IN>))
712 <COND (<SET OB <MUNG-LAB .OB .ATM>>
718 <PRINTTYPE SKIP-INS ,HACK-PRINT>
720 <PRINTTYPE JUMP-INS ,HACK-PRINT>
722 <DEFINE PEEP-PRINT (LN NLN NUMLABS NNUMLABS)
723 <COND (<NOT <ASSIGNED? OUTL>>
725 <SET LN <- .LN .NUMLABS>>
726 <SET NLN <- .NLN .NUMLABS <- .NNUMLABS>>>
727 <PRIN1 <FIX <* 100 </ <FLOAT <- .LN .NLN>> .LN>>>>
734 <SET LN <- .LN .NUMLABS>>
735 <SET NLN <- .NLN .NUMLABS <- .NNUMLABS>>>
736 <PRINL1 <FIX <* 100 </ <FLOAT <- .LN .NLN>> .LN>>>>
742 <DEFINE CLEAN-IT-UP (MDLN)
743 #DECL ((MDLN) <LIST [REST LNODE]>)
745 <FUNCTION (LND "AUX" JMP FIN-LNODE)
748 (<OR <AND <TYPE? <SET JMP <1 <CODE-LN .LND>>> JUMP-INS>
750 <SET FIN-LNODE <FIND-END-OF-CHAIN .JMP>>>
751 <AND <TYPE? <SET JMP <1 <BACK <CODE-LN .LND>>>> ATOM>
752 <SET JMP <FIND-NOD .MDLN .JMP>>
753 <==? <CODE-LN .JMP> <BACK <CODE-LN .LND>>>
754 <SET FIN-LNODE .JMP>>>
756 <FUNCTION (JMPL "AUX" JMP)
757 #DECL ((JMPL) TUPLE (JMP) JUMP-INS)
760 <PUT .JMP ,WHERE-JMP .FIN-LNODE>
763 <ADDON (.JMPL) <JUMPS-LN .FIN-LNODE>>>>
766 <FLUSH-LABELS .MDLN>>
768 <DEFINE FIND-END-OF-CHAIN (JMP "AUX" (DEFAULT <WHERE-JMP .JMP>))
769 #DECL ((JMP) JUMP-INS)
771 <COND (<TYPE? <SET NJMP <1 <CODE-LN <WHERE-JMP .JMP>>>>
773 <SET DEFAULT <WHERE-JMP .JMP>>
775 (<RETURN .DEFAULT>)>>>
777 <DEFINE FLUSH-LABELS (MODLN "AUX" (TEM ()))
778 #DECL ((MODLN) LIST (SLABS) <LIST [REST LNODE]> (NLABLS) <LIST [REST LIST]>
781 <FUNCTION (Y "AUX" (X <1 .Y>)) #DECL ((Y) <LIST LNODE [REST LNODE]>
783 <COND (<AND <NOT <MEMQ .X .SLABS>>
784 <EMPTY? <JUMPS-LN .X>>
786 <REPEAT ((N .NLABLS) N1 (LL <LABLS-LN .X>))
787 #DECL ((N1 N) <LIST [REST LIST]>
788 (LL) <LIST [REST ATOM]>)
789 <AND <EMPTY? .N> <RETURN>>
790 <COND (<MEMQ <1 <1 .N>> .LL>
791 <COND (<==? .N .NLABLS>
792 <SET NLABLS <REST .NLABLS>>)
793 (ELSE <PUTREST .N1 <REST .N>>)>
795 <SET N <REST <SET N1 .N>>>>
796 <COND (<==? .Y .MODLN> <SET MODLN <REST .MODLN>>)
797 (ELSE <PUTREST .TEM <REST .Y>> <SET Y .TEM>)>
798 <COND (<==? <NAME-LN .X> <1 <CODE-LN .X>>>
799 <PUT <CODE-LN .X> 1 ,NULL-INST>
800 <SET NNUMLABS <+ .NNUMLABS 1>>)>
801 <SET REDO "FLUSH REDUNDANT LABELS">)>