<mdl.comp>/peeph.mud.92

   1 <PACKAGE "PEEPH">
   2
   3 <ENTRY PEEP PRT>
   4
   5 <USE "COMPDEC">
   6
   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."
  10
  11 <SETG INSTRUCTION ,FORM>
  12
  13 <BLOCK (<ROOT>)>
  14
  15 TMP
  16
  17 <ENDBLOCK>
  18
  19 <SETG SKIP-TBL ![4 5 6 7 0 1 2 3!]>
  20
  21 <SETG TEST-TBL ![2 3 0 1!]>
  22
  23 <MANIFEST SKIP-TBL TEST-TBL>
  24
  25 <NEWTYPE LNODE VECTOR '<VECTOR LIST LIST <OR FALSE TUPLE> ATOM>>
  26
  27 <SETG LABLS-LN 1>
  28
  29 <SETG JUMPS-LN 2>
  30
  31 <SETG CODE-LN 3>
  32
  33 <SETG NAME-LN 4>
  34
  35 <NEWTYPE NULL LIST>
  36
  37 <SETG NULL-INST <CHTYPE () NULL>>
  38
  39 <NEWTYPE JUMP-INS
  40          LIST
  41          '<LIST <PRIMTYPE WORD> FIX <OR 'T FALSE> <OR FALSE LNODE>>>
  42
  43 <SETG INS-JMP 1>
  44
  45 <SETG COND-JMP 2>
  46
  47 <SETG UNCON-JMP 3>
  48
  49 <SETG WHERE-JMP 4>
  50
  51 <NEWTYPE SKIP-INS LIST '<LIST <PRIMTYPE WORD>
  52                               FIX
  53                               <OR 'T FALSE>
  54                               <OR 'T FALSE>>>
  55
  56 <SETG INS-SKP 1>
  57
  58 <SETG COND-SKP 2>
  59
  60 <SETG TEST-SKP 3>
  61
  62 <SETG UNCON-SKP 4>
  63
  64 <MANIFEST LABLS-LN
  65           JUMPS-LN
  66           CODE-LN
  67           NAME-LN
  68           NULL-INST
  69           INS-JMP
  70           COND-JMP
  71           UNCON-JMP
  72           WHERE-JMP
  73           INS-SKP
  74           COND-SKP
  75           TEST-SKP
  76           UNCON-SKP>
  77
  78 "CODE RANGES"
  79
  80 <SETG JRST1 172>
  81
  82 <SETG LOW-SKP1 192>
  83
  84 <SETG HI-SKP1 207>
  85
  86 <SETG LOW-JMP1 208>
  87
  88 <SETG HI-JMP1 215>
  89
  90 <SETG LO-SKP2 216>
  91
  92 <SETG HI-SKP2 223>
  93
  94 <SETG LO-JMP2 224>
  95
  96 <SETG HI-JMP2 255>
  97
  98 <SETG LO-TST1 384>
  99
 100 <SETG HI-TST1 447>
 101
 102 <MANIFEST JRST1
 103           LOW-SKP1
 104           HI-SKP1
 105           LOW-JMP1
 106           HI-JMP1
 107           LO-SKP2
 108           HI-SKP2
 109           LO-JMP2
 110           HI-JMP2
 111           LO-TST1
 112           HI-TST1>
 113
 114 \\f
 115
 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."
 118
 119 <DEFINE PEEP (XCOD
 120               "TUPLE" COD
 121               "AUX" QXD (MODLN (())) NNCOD (LABNUM 0) (NUMLABS 0) (NNUMLABS 0)
 122                     NLN (LN <LENGTH .COD>) XD QD (SLABS ()) (TOPCOD .COD)
 123                     TEMP)
 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)
 127            #DECL ((CPTR) TUPLE)
 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>
 132                            <SET AT <2 .AT>>>
 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>>
 137                   <REPEAT (IN)
 138                           <AND <EMPTY? <SET CPTR <REST .CPTR>>>
 139                                <RETURN T .TG-FND>>
 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>)
 144                                 (<RETURN>)>>)
 145                  (<SET CPTR <REST .CPTR>>)>>
 146    <SET MODLN <REST .MODLN>>
 147    <MAPR <>
 148     <FUNCTION (RCOD "AUX" QD (INST <1 .RCOD>))
 149        #DECL ((QD) <OR FALSE LNODE> (RCOD) TUPLE)
 150        <COND
 151         (<TYPE? .INST FORM>
 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>)>>
 156                 <AND .XD
 157                      <PROG FFA ()
 158                            <COND (.QD
 159                                   <PUT .INST ,WHERE-JMP .QD>
 160                                   <PUT .RCOD 1 .INST>
 161                                   <PUT .QD
 162                                        ,JUMPS-LN
 163                                        <ADDON (.RCOD) <JUMPS-LN .QD>>>)
 164                                  (<SET QD <CHTYPE [(.XD) () <> .XD] LNODE>>
 165                                   <SET MODLN (.QD !.MODLN)>
 166                                   <AGAIN .FFA>)>>>)
 167                (ELSE
 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>)>)>>
 173     .COD>
 174    <PROG REOPT ((NLABLS ()) (REDO <>))
 175      #DECL ((NLABLS) <SPECIAL LIST> (REDO) <SPECIAL <OR STRING FALSE ATOM>>)
 176      <MAPR <>
 177       <FUNCTION (NCOD "AUX" QD (INST <1 .NCOD>) (NNCOD .NCOD))
 178          #DECL ((NNCOD NCOD) TUPLE)
 179          <COND
 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>>
 184              <COND
 185               (<AND <NOT <G? <INS-JMP .INST> ,LO-JMP2>>
 186                     <REPEAT ((NC .NNCOD))
 187                             <COND (<==? .NC .TOPCOD> <RETURN>)>
 188                             <SET NC <BACK .NC>>
 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>>)>>>
 196                <DEL-JUMP-LN .NNCOD>
 197                <PUT .NNCOD 1 ,NULL-INST>
 198                <SET REDO "REMOVED JUMP CHAINING">
 199                <RETURN>)
 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>>>>>
 204                       <DEL-JUMP-LN .NNCOD>
 205                       <SET NEWLAB <ADDON (.NNCOD) <JUMPS-LN <WHERE-JMP .QD>>>>
 206                       <COND (.AOJ-FLG
 207                              <PUT .NNCOD
 208                                   1
 209                                   <SET INST <CHTYPE <SUBSTRUC .QD> JUMP-INS>>>)
 210                             (ELSE
 211                              <PUT .INST ,WHERE-JMP <WHERE-JMP .QD>>
 212                              <PUT <WHERE-JMP .QD> ,JUMPS-LN .NEWLAB>)>
 213                       <SET REDO "REMOVED JUMP CHAINING">)
 214                      (<RETURN>)>)
 215               (<RETURN>)>>
 216            <COND
 217             (<AND
 218               <NOT <UNCON-JMP .INST>>
 219               <REPEAT ((NC .NCOD))
 220                 <COND
 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>>>)
 227                  (ELSE <RETURN <>>)>>
 228               <NOT <SKIPPABLE <BACKS .NCOD .TOPCOD <> 1>>>>
 229              <DEL-JUMP-LN .NCOD>
 230              <PUT .INST ,WHERE-JMP <WHERE-JMP <1 .TEMP>>>
 231              <DEL-JUMP-LN .TEMP>
 232              <PUT .TEMP 1 ,NULL-INST>
 233              <PUT <WHERE-JMP .INST>
 234                   ,JUMPS-LN
 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>
 239            <AND
 240             <NOT <UNCON-SKP .INST>>
 241             <REPEAT ()
 242               <COND
 243                (<EMPTY? <SET NCOD <REST .NCOD>>> <RETURN>)
 244                (<AND <OR <AND <TYPE? <SET QD <1 .NCOD>> SKIP-INS>
 245                               <NOT <TEST-SKP .QD>>
 246                               <UNCON-SKP .QD>
 247                               <NOT <TYPE? <BACKS .NCOD .TOPCOD <> 2>
 248                                           SKIP-INS>>>
 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>
 256                      <PUT .NCOD 1 .INST>
 257                      <CHANGE-COND .INST>
 258                      <SET REDO "SKIP-CHAIN OPTIMIZATION">
 259                      <RETURN>>)
 260                (<NOT <TYPE? .QD NULL>> <RETURN>)>>>
 261            <AND <TYPE? <SET XD <1 .NCOD>> JUMP-INS>
 262                 <NOT <TYPE? <BACKS .NCOD .TOPCOD <> 2> SKIP-INS>>
 263                 <UNCON-JMP .XD>
 264                 <SET QXD <WHERE-JMP .XD>>
 265                 <TYPE? <NEXTS <REST .NCOD>> SKIP-INS>
 266                 <TYPE? <SET XD <NEXTS <REST .NCOD> <> 2>> JUMP-INS>
 267                 <UNCON-JMP .XD>
 268                 <==? <WHERE-JMP .XD> .QXD>
 269                 <DEL-JUMP-LN .NCOD>
 270                 <PUT .NCOD 1 ,NULL-INST>
 271                 <CHANGE-COND .INST>
 272                 <SET REDO "OPTIMIZING CONDITIONAL JUMPS">>)
 273           (<AND
 274             <TYPE? .INST FORM>
 275             <OR <==? <1 .INST> `ADDI > <==? <1 .INST> `SUBI >>
 276             <==? <LENGTH .INST> 3>
 277             <==? <3 .INST> 1>
 278             <REPEAT (TEM)
 279               <COND (<EMPTY? .NCOD> <RETURN>)>
 280               <SET NCOD <REST .NCOD>>
 281               <COND
 282                (<TYPE? <SET QD <1 .NCOD>> JUMP-INS>
 283                 <COND
 284                  (<OR <==? <INS-JMP .QD> ,JRST1>
 285                       <AND <G=? <INS-JMP .QD> ,LOW-JMP1>
 286                            <L=? <INS-JMP .QD> ,HI-JMP1>
 287                            <G=? <LENGTH .QD> 5>
 288                            <==? <2 .INST> <5 .QD>>>>
 289                   <PUT <BACK .NCOD> 1 ,NULL-INST>
 290                   <PUT
 291                    .NCOD
 292                    1
 293                    <SET TEM
 294                     <INSTYPE
 295                      <INSTRUCTION
 296                       <COND
 297                        (<==? <INS-JMP .QD> ,JRST1>
 298                         <COND (<==? <1 .INST> `ADDI > `AOJA ) (ELSE `SOJA )>)
 299                        (<==? <1 .INST> `ADDI >
 300                         <CHTYPE <PUTBITS 0
 301                                          <BITS 9 27>
 302                                          <+ <CHTYPE <INS-JMP .QD> FIX> 16>>
 303                                 OPCODE!-OP!-PACKAGE>)
 304                        (ELSE
 305                         <CHTYPE <PUTBITS 0
 306                                          <BITS 9 27>
 307                                          <+ <CHTYPE <INS-JMP .QD> FIX> 32>>
 308                                 OPCODE!-OP!-PACKAGE>)>
 309                       <2 .INST>
 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">
 314                   <RETURN <>>)
 315                  (<RETURN>)>)
 316                (<TYPE? .QD NULL>)
 317                (<RETURN>)>>>
 318            <SET NCOD .NNCOD>
 319            <REPEAT ()
 320              <AND <==? .NCOD .TOPCOD> <RETURN>>
 321              <SET NCOD <BACK .NCOD>>
 322              <COND
 323               (<TYPE? <SET QD <1 .NCOD>> NULL>)
 324               (<TYPE? .QD ATOM>
 325                <SET QD <FIND-NOD .MODLN .QD>>
 326                <COND
 327                 (<MAPF <>
 328                   <FUNCTION (X)
 329                           <COND (<NOT <OR <TYPE? <1 .X> NULL>
 330                                           <==? <INS-JMP <1 .X>> ,JRST1>>>
 331                                  <MAPLEAVE <>>)
 332                                 (T)>>
 333                   <JUMPS-LN .QD>>
 334                  <SET REDO "JUMP TO AN ADDI OR SUBI">
 335                  <PUT .NCOD 1 <1 .NNCOD>>
 336                  <PUT .NNCOD 1 <NAME-LN .QD>>
 337                  <MAPF <>
 338                   <FUNCTION (X
 339                              "AUX" (IT
 340                                     <COND (<==? <1 .INST> `ADDI > `AOJA )
 341                                           (ELSE `SOJA )>))
 342                           <PUT
 343                            .X
 344                            1
 345                            <PUT <INSTYPE <INSTRUCTION
 346                                           .IT <2 .INST> <NAME-LN .QD>>>
 347                                 ,WHERE-JMP
 348                                 .QD>>>
 349                   <JUMPS-LN .QD>>)>
 350                <RETURN>)
 351               (<RETURN>)>>)
 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>)>)>>
 358       .COD>
 359      <MAPF <>
 360       <FUNCTION (LN "AUX" (COMPS <JUMPS-LN .LN>))
 361          #DECL ((LN) LNODE)
 362          <COND
 363           (<NOT <EMPTY? .COMPS>>
 364            <SET COMPS
 365                 <MAPF ,LIST
 366                       <FUNCTION (CMP)
 367                               #DECL ((CMP) TUPLE)
 368                               <COND (<AND <UNCON-JMP <1 .CMP>>
 369                                           <==? <INS-JMP <1 .CMP>> ,JRST1>>
 370                                      <MAPRET .CMP>)
 371                                     (<MAPRET>)>>
 372                       .COMPS>>
 373            <AND <CODE-LN .LN> <CROSS-OPT .TOPCOD <CODE-LN .LN> !.COMPS>>
 374            <SET COMPS <JUMPS-LN .LN>>
 375            <SET COMPS
 376                 <MAPF ,LIST
 377                       <FUNCTION (CMP)
 378                               #DECL ((CMP) TUPLE)
 379                               <COND (<AND <UNCON-JMP <1 .CMP>>
 380                                           <==? <INS-JMP <1 .CMP>> ,JRST1>>
 381                                      <MAPRET .CMP>)
 382                                     (<MAPRET>)>>
 383                       .COMPS>>
 384            <MAPR <>
 385                  <FUNCTION (CMP)
 386                          #DECL ((CMP) LIST)
 387                          <CROSS-OPT .TOPCOD <1 .CMP> !<REST .CMP>>>
 388                  .COMPS>)>>
 389       .MODLN>
 390      <SET MODLN <CLEAN-IT-UP .MODLN>>
 391      <MAPR <>
 392       <FUNCTION (NCOD "AUX" (INST <1 .NCOD>))
 393          #DECL ((NCOD) TUPLE)
 394          <COND
 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>>>>)>>>
 404            <REPEAT ()
 405              <COND
 406               (<EMPTY? <SET NCOD <REST .NCOD>>> <RETURN>)
 407               (<OR
 408                 <TYPE? <SET QD <1 .NCOD>> ATOM>
 409                 <AND <TYPE? .QD FORM>
 410                      <OR <==? <1 .QD> INTERNAL-ENTRY!-OP!-PACKAGE>
 411                          <PSEUDO? .QD>
 412                          <AND <TYPE? <1 .QD> ATOM>
 413                               <OR <FIND-NOD .MODLN <1 .QD>>
 414                                   <NOT <GASSIGNED? <1 .QD>>>>>>>
 415                 <MAPF <>
 416                  <FUNCTION (LN)
 417                          #DECL ((LN) LNODE)
 418                          <COND (<AND <NOT <EMPTY? <JUMPS-LN .LN>>>
 419                                      <==? <CODE-LN .LN> .NCOD>>
 420                                 <MAPLEAVE>)>>
 421                  .MODLN>>
 422                <RETURN>)
 423               (<TYPE? .QD NULL>)
 424               (ELSE
 425                <COND (<TYPE? <1 .NCOD> JUMP-INS> <DEL-JUMP-LN .NCOD>)>
 426                <PUT .NCOD 1 ,NULL-INST>
 427                <SET REDO "FLUSH UNREACHABLE CODE">)>>)>>
 428       .COD>
 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)
 433              <MAPF <>
 434                    <FUNCTION (X) <COND (<==? <2 .X> .PTR1> <PUT .X 2 .PTR2>)>>
 435                    .NLABLS>
 436              <COND (<TYPE? <SET XD <1 .PTR1>> NULL>)
 437                    (<PUT .PTR2 1 .XD>
 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>>>
 443                                 1
 444                                 .PTR2>)>
 445                     <SET PTR2 <BACK .PTR2>>)>
 446              <COND (<==? .PTR1 .TOPCOD>
 447                     <REPEAT ()
 448                             <COND (<==? .PTR2 .TOPCOD>
 449                                    <PUT .PTR2 1 ,NULL-INST>
 450                                    <RETURN T .FFY>)
 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>
 457                     <RETURN>)>
 458              <MAPF <>
 459                    <FUNCTION (X)
 460                            <COND (<==? <2 .X> .PTR1>
 461                                   <SET NNUMLABS <- .NNUMLABS 1>>
 462                                   <PUT .PTR2 1 <1 .X>>
 463                                   <PUT <FIND-NOD .MODLN <1 .X>> ,CODE-LN .PTR2>
 464                                   <SET PTR2 <REST .PTR2>>)>>
 465                    .NLABLS>
 466              <COND (<TYPE? <SET P1 <1 .PTR1>> NULL>)
 467                    (ELSE
 468                     <COND (<NOT .REDO> <PUT .PTR2 1 <INSFIX .P1>>)
 469                           (<PUT .PTR2 1 .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>>>
 475                                 1
 476                                 .PTR2>)>
 477                     <SET PTR2 <REST .PTR2>>)>
 478              <SET PTR1 <REST .PTR1>>>
 479      <COND (.REDO <SET NLABLS ()> <SET REDO <>> <AGAIN .REOPT>)
 480            (ELSE
 481             <SET NLN
 482                  <REPEAT ((N 0))
 483                          <COND (<EMPTY? .COD> <RETURN .N>)
 484                                (<TYPE? <1 .COD> NULL>)
 485                                (ELSE
 486                                 <PUT .XCOD 1 <1 .COD>>
 487                                 <SET NNCOD .XCOD>
 488                                 <SET XCOD <REST .XCOD>>
 489                                 <SET N <+ .N 1>>)>
 490                          <SET COD <REST .COD>>>>
 491             <OR <EMPTY? .NNCOD> <PUTREST .NNCOD ()>>)>>
 492    <COND (<AND <ASSIGNED? PEEP> .PEEP>
 493           <PEEP-PRINT .LN .NLN .NUMLABS .NNUMLABS>)>>
 494
 495 \\f
 496
 497 <DEFINE INSTYPE (INST "AUX" AT QX QY)
 498         #DECL ((QX) <PRIMTYPE WORD>)
 499         <COND
 500          (<AND <TYPE? .INST FORM>
 501                <TYPE? <SET AT <1 .INST>> OPCODE!-OP!-PACKAGE>
 502                <SET QX <CHTYPE <GETBITS .AT <BITS 9 27>> FIX>>
 503                <OR <==? .QX ,JRST1>
 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>)
 511                 (.INST)>)
 512          (<AND <ASSIGNED? QX>
 513                <G=? .QX ,LO-TST1>
 514                <L=? .QX ,HI-TST1>
 515                <NOT <0? <SET QY <CHTYPE <GETBITS .QX <BITS 2 1>> FIX>>>>>
 516           <CHTYPE (.QX .QY T <==? .QY 2> !<REST <CHTYPE .INST LIST>>)
 517                   SKIP-INS>)
 518          (.INST)>>
 519
 520 <DEFINE NFIND-LAB (INST)
 521         <COND (<TYPE? .INST ATOM> .INST)
 522               (<MONAD? .INST> <>)
 523               (<MAPF <>
 524                      <FUNCTION (X)
 525                              <COND (<SET X <NFIND-LAB .X>> <MAPLEAVE .X>)>>
 526                      .INST>)>>
 527
 528 <DEFINE FIND-NOD (MD AT)
 529         #DECL ((MD) LIST (AT) ATOM)
 530         <MAPF <>
 531               <FUNCTION (X)
 532                       #DECL ((X) LNODE)
 533                       <COND (<MEMQ .AT <LABLS-LN .X>> <MAPLEAVE .X>)>>
 534               .MD>>
 535
 536 <DEFINE INSFIX (X "AUX" XD)
 537    <COND
 538     (<TYPE? .X JUMP-INS>
 539      <INSTRUCTION
 540       <CHTYPE <PUTBITS #WORD *000000000000*
 541                        <BITS 9 27>
 542                        <CHTYPE <ORB <ANDB <INS-JMP .X> 504> <COND-JMP .X>> FIX>>
 543               OPCODE!-OP!-PACKAGE>
 544       !<COND (<==? <LENGTH <SET XD <REST .X 4>>> 2>
 545               (<1 .XD> <NAME-LN <WHERE-JMP .X>>))
 546              (ELSE (<NAME-LN <WHERE-JMP .X>>))>>)
 547     (<TYPE? .X SKIP-INS>
 548      <INSTRUCTION
 549       <COND (<TEST-SKP .X>
 550              <CHTYPE <PUTBITS #WORD *000000000000*
 551                               <BITS 9 27>
 552                               <CHTYPE <ORB <ANDB <INS-SKP .X> 505>
 553                                            <* <COND-SKP .X> 2>>
 554                                       FIX>>
 555                      OPCODE!-OP!-PACKAGE>)
 556             (ELSE
 557              <CHTYPE <PUTBITS #WORD *000000000000*
 558                               <BITS 9 27>
 559                               <CHTYPE <ORB <ANDB <INS-SKP .X> 504>
 560                                            <COND-SKP .X>>
 561                                       FIX>>
 562                      OPCODE!-OP!-PACKAGE>)>
 563       !<REST .X 4>>)
 564     (ELSE .X)>>
 565
 566 <DEFINE PRT (X)
 567         #DECL ((X) STRUCTURED)
 568         <MAPF <>
 569               <FUNCTION (X)
 570                       <COND (<TYPE? .X ATOM>) (ELSE <PRINC "    ">)>
 571                       <PRIN1 .X>
 572                       <CRLF>>
 573               .X>>
 574
 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>>
 581      <MAPR <>
 582            <FUNCTION (XD "AUX" (XR <1 .XD>))
 583                    #DECL ((XD) TUPLE (XR) <OR TUPLE NULL>)
 584                    <COND (<TYPE? .XR NULL>)
 585                          (<==? .XR .TOPCOD>)
 586                          (ELSE
 587                           <REPEAT ()
 588                                   <PUT .XD 1 <SET XR <BACK .XR>>>
 589                                   <SET CNT -1>
 590                                   <COND (<TYPE? <1 .XR> NULL>) (<RETURN>)>>)>>
 591            .COMPS>
 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>>
 595      <SET QD <1 .NCOD>>
 596      <COND (<OR <SKIPPABLE <1 <BACK .NCOD>>> <SKIPPABLE <1 .NCOD>>> <RETURN>)>
 597      <MAPR <>
 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>>
 603                             <SET NEEDLABEL T>
 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>)
 608                                   (ELSE
 609                                    <PUT .NNCOD
 610                                         1
 611                                         <CHTYPE (,JRST1 4 T .NEWLN .LABL)
 612                                                 JUMP-INS>>
 613                                    <PUT .NEWLN
 614                                         ,JUMPS-LN
 615                                         (.NNCOD !<JUMPS-LN .NEWLN>)>)>
 616                             <SET REDO "CROSS-OPTIMIZATION">
 617                             <SET CNT -1>)
 618                            (<PUT .NPCOD 1 ,NULL-INST>)>)>>
 619       .COMPS>
 620      <COND (<NOT <0? .CNT>>
 621             <SET NLABLS ((.LABL .NCOD) !.NLABLS)>
 622             <SET MODLN (.NEWLN !.MODLN)>)>
 623      <COND (<0? .CNT> <RETURN>) (<SET CNT 0>)>>>
 624
 625 <DEFINE FF (X) #DECL ((X) STRUCTURED) <MAPF <> ,& .X> <CRLF>>
 626
 627 "ROUTINE TO DETERMINE WHETHER AN INSTRUCTION CAN SKIP"
 628
 629 <DEFINE HACK-PRINT (X) <PRIN1 <INSFIX .X>>>
 630
 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>>>>>>
 638
 639 "ROUTINE TO DELETE A JUMP-LN FROM AN LNODE."
 640
 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>
 645                                                         LNODE>>>>>
 646                <COND (<==? .QD .XD> <PUT <CHTYPE <WHERE-JMP .JMP> LNODE>
 647                                          ,JUMPS-LN <REST .XD>>)
 648                      (ELSE
 649                       <PUTREST <REST .QD <- <LENGTH .QD> <LENGTH .XD> 1>>
 650                                <REST .XD>>)>
 651                T)>>
 652
 653 <DEFINE CHANGE-COND (INST)
 654         #DECL ((INST) SKIP-INS)
 655         <PUT .INST
 656              ,COND-SKP
 657              <COND (<TEST-SKP .INST> <NTH ,TEST-TBL <+ <COND-SKP .INST> 1>>)
 658                    (<NTH ,SKIP-TBL <+ <COND-SKP .INST> 1>>)>>>
 659
 660 <DEFINE MAKE:LABEL ("AUX" XX) #DECL ((LABNUM) FIX)
 661         <OR <LOOKUP <SET XX
 662                          <STRING "OPT" <UNPARSE <SET LABNUM <+ .LABNUM 1>>>>>
 663                     <GET TMP OBLIST>>
 664             <INSERT .XX <GET TMP OBLIST>>>>
 665
 666 <DEFINE NEXTS (XX "OPTIONAL" (XT <>) (NN 1) "AUX" XR)
 667         #DECL ((XX) TUPLE (NN) FIX)
 668         <REPEAT ()
 669                 <COND (<TYPE? <SET XR <1 .XX>> NULL ATOM>)
 670                       (<0? <SET NN <- .NN 1>>> <RETURN .XR>)>
 671                 <AND <EMPTY? <SET XX <REST .XX>>>
 672                      <SET XX <BACK .XX>>
 673                      <RETURN .XR>>>
 674         <COND (.XT .XX) (ELSE .XR)>>
 675
 676 <DEFINE BACKS (XX TOPCOD "OPTIONAL" (XT <>) (NN 1) "AUX" XR)
 677         #DECL ((XX TOPCOD) TUPLE (NN) FIX)
 678         <REPEAT ()
 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)>>
 683
 684
 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)>>
 689
 690 <DEFINE FIND-LAB (INST)
 691         <MAPF <>
 692               <FUNCTION (X) <COND (<TYPE? .X ATOM> <MAPLEAVE .X>)>>
 693               .INST>>
 694
 695 <DEFINE PSEUDO? (AT)
 696         #DECL ((VALUE) <OR ATOM FALSE>)
 697         <AND <TYPE? .AT FORM>
 698              <==? <1 .AT> PSEUDO!-OP!-PACKAGE>
 699              <==? <LENGTH .AT> 2>
 700              <TYPE? <SET AT <2 .AT>> FORM>
 701              <==? <LENGTH .AT> 3>
 702              <==? <1 .AT> SETG>
 703              <=? <3 .AT> '<ANDB 262143 <CHTYPE .HERE!-OP!-PACKAGE FIX>>>
 704              <2 .AT>>>
 705
 706 <DEFINE MUNG-LAB (INST ATM)
 707         <COND (<TYPE? .INST ATOM> .ATM)
 708               (<MONAD? .INST> <>)
 709               (ELSE
 710                <MAPR <>
 711                      <FUNCTION (IN "AUX" (OB <1 .IN>))
 712                              <COND (<SET OB <MUNG-LAB .OB .ATM>>
 713                                     <PUT .IN 1 .OB>
 714                                     <MAPLEAVE <>>)>>
 715                      .INST>
 716                .INST)>>
 717
 718 <PRINTTYPE SKIP-INS ,HACK-PRINT>
 719
 720 <PRINTTYPE JUMP-INS ,HACK-PRINT>
 721
 722 <DEFINE PEEP-PRINT (LN NLN NUMLABS NNUMLABS)
 723     <COND (<NOT <ASSIGNED? OUTL>>
 724         <PRINC "Peephole  ">
 725         <SET LN <- .LN .NUMLABS>>
 726         <SET NLN <- .NLN .NUMLABS <- .NNUMLABS>>>
 727         <PRIN1 <FIX <* 100 </ <FLOAT <- .LN .NLN>> .LN>>>>
 728         <PRINC "% ">
 729         <PRIN1 .LN>
 730         <PRINC "/">
 731         <PRIN1 .NLN>)
 732        (ELSE
 733         <PRINLC "Peephole   ">
 734         <SET LN <- .LN .NUMLABS>>
 735         <SET NLN <- .NLN .NUMLABS <- .NNUMLABS>>>
 736         <PRINL1 <FIX <* 100 </ <FLOAT <- .LN .NLN>> .LN>>>>
 737         <PRINLC "% ">
 738         <PRINL1 .LN>
 739         <PRINLC "/">
 740         <PRINL1 .NLN>)>>
 741 \f
 742 <DEFINE CLEAN-IT-UP (MDLN)
 743    #DECL ((MDLN) <LIST [REST LNODE]>)
 744    <MAPF <>
 745     <FUNCTION (LND "AUX" JMP FIN-LNODE)
 746             #DECL ((LND) LNODE)
 747             <COND
 748              (<OR <AND <TYPE? <SET JMP <1 <CODE-LN .LND>>> JUMP-INS>
 749                        <UNCON-JMP .JMP>
 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>>>
 755               <MAPF <>
 756                     <FUNCTION (JMPL "AUX" JMP)
 757                             #DECL ((JMPL) TUPLE (JMP) JUMP-INS)
 758                             <DEL-JUMP-LN .JMPL>
 759                             <SET JMP <1 .JMPL>>
 760                             <PUT .JMP ,WHERE-JMP .FIN-LNODE>
 761                             <PUT .FIN-LNODE
 762                                  ,JUMPS-LN
 763                                  <ADDON (.JMPL) <JUMPS-LN .FIN-LNODE>>>>
 764                     <JUMPS-LN .LND>>)>>
 765     .MDLN>
 766    <FLUSH-LABELS .MDLN>>
 767
 768 <DEFINE FIND-END-OF-CHAIN (JMP "AUX" (DEFAULT <WHERE-JMP .JMP>))
 769         #DECL ((JMP) JUMP-INS)
 770         <REPEAT (NJMP)
 771                 <COND (<TYPE? <SET NJMP <1 <CODE-LN <WHERE-JMP .JMP>>>>
 772                               JUMP-INS>
 773                        <SET DEFAULT <WHERE-JMP .JMP>>
 774                        <SET JMP .NJMP>)
 775                       (<RETURN .DEFAULT>)>>>
 776
 777 <DEFINE FLUSH-LABELS (MODLN "AUX" (TEM ()))
 778    #DECL ((MODLN) LIST (SLABS) <LIST [REST LNODE]> (NLABLS) <LIST [REST LIST]>
 779           (NNUMLABS) FIX)
 780    <MAPR <>
 781     <FUNCTION (Y "AUX" (X <1 .Y>)) #DECL ((Y) <LIST LNODE [REST LNODE]>
 782                                           (X) LNODE)
 783             <COND (<AND <NOT <MEMQ .X .SLABS>>
 784                         <EMPTY? <JUMPS-LN .X>>
 785                         <CODE-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>>)>
 794                                   <RETURN>)>
 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">)>
 802             <SET TEM .Y>>
 803     .MODLN>
 804    .MODLN>
 805 \f
 806 <ENDPACKAGE>
 807 \ 3