mim/development/mim/20c/peep.mud

   1 <COND (<NOT <GASSIGNED? WIDTH-MUNG>> <FLOAD "MIMOC20DEFS.MUD">)>
   2
   3 <SETG DONT-HACK T>
   4
   5 <SETG PEEP-CHANNEL <>>
   6
   7 <NEWTYPE OLD-AND-USELESS VECTOR>
   8
   9 <NEWTYPE LOCAL-NAME FIX>
  10
  11 <NEWTYPE CONSTANT FIX>
  12
  13 <NEWTYPE CONSTANT-LABEL FIX>
  14
  15 <NEWTYPE REF VECTOR>
  16
  17 <NEWTYPE INST VECTOR>
  18
  19 <NEWTYPE GFRM ATOM>
  20
  21 <NEWTYPE SGFRM ATOM>
  22
  23 <DEFINE REF-PRINT (R) #DECL ((R) REF)
  24         <PRIN1 <1 .R>>>
  25
  26
  27
  28 ;"----------------------------------------------------------------------------"
  29
  30 <DEFINE PPOLE (CODE-L "TUPLE" T "AUX" (PREPREV <>) (PREVIOUS <>) ZERO)
  31    #DECL ((T) <PRIMTYPE VECTOR>
  32           (PREVIOUS) <SPECIAL <OR FALSE REF INST OLD-AND-USELESS>>
  33           (CODE-L) LIST)
  34    <PRINTTYPE REF ,REF-PRINT>
  35    <GENERATE-CIRCULAR-REFERENCES .T>
  36    <MAPR <>
  37     <FUNCTION (NEW-T "AUX" (ITM <1 .NEW-T>) BACKLIST OPP REFERENCE NXT TMP)
  38             #DECL ((NEW-T) <SPECIAL <PRIMTYPE VECTOR>>
  39                    (ITM) <OR INST REF OLD-AND-USELESS> (BACKLIST) LIST)
  40             <COND (<TYPE? .ITM OLD-AND-USELESS>)
  41                   (<TYPE? .ITM REF>                   ;"Handling of references"
  42                    <DELETE-ADJACENT-REFS .NEW-T>
  43                    <COND (<UNCONDITIONAL-BRANCH? <2 .NEW-T>>
  44                           <BRANCH-CHAIN .NEW-T>)>
  45                    <SETG CIRC-LOOP?
  46                          <AND <GASSIGNED? LOOPTAGS> <MEMQ <1 .ITM> ,LOOPTAGS>>>
  47                    <COND (.PREPREV <POST-ACCESS .ITM .NEW-T>)>
  48                    <COND (<AND <EMPTY? <3 .ITM>>
  49                                <NOT <MEMQ <1 .ITM> ,LOCATIONS>>>
  50                           <PUT .NEW-T 1 <CHTYPE [<1 .NEW-T>] OLD-AND-USELESS>>)
  51                          (<AND <NOT ,DONT-HACK>
  52                                <NOT <2 .ITM>>
  53                                <TYPE? <1 .NEW-T> REF>
  54                                <1? <LENGTH <3 .ITM>>>>
  55                           <SINGLE-PATH-OPTIMIZE .T .NEW-T>)>)
  56                   (<UNCONDITIONAL-BRANCH? .ITM>
  57                    <SKIP-MODIFY .NEW-T .PREVIOUS .PREPREV>)
  58                   (<CONDITIONAL-BRANCH? .ITM>
  59                    <COND (<AND <NOT <EMPTY? <REST .NEW-T>>>
  60                                <UNCONDITIONAL-BRANCH? <2 .NEW-T>>
  61                                <==? <NTH .ITM <LENGTH .ITM>> <3 .NEW-T>>
  62                                <SET OPP <GETPROP <1 .ITM> OPPOSITE>>>
  63                           <SET REFERENCE <2 <2 .NEW-T>>>
  64                           <PUT <1 .NEW-T> 1 .OPP>
  65                           <PUT <1 .NEW-T> 3 .REFERENCE>
  66                           <PUT .REFERENCE 3 (<1 .NEW-T> !<3 .REFERENCE>)>
  67                           <PUT .NEW-T 2 <ELIMINATE <2 .NEW-T>>>)>)
  68                   (<AND <NOT ,DONT-HACK> <NOT ,CIRC-LOOP?> <MOVE? .ITM>>
  69                    <MOVE-CHECK .NEW-T .ITM>
  70                    <MOVE-NEEDED? .NEW-T .ITM>)
  71                   (<AND <==? <1 .ITM> PUSH>
  72                         <TYPE? <2 .ITM> ATOM>
  73                         <SET ZERO <FINDZERO>>>
  74                    <PUSH-OPTIMIZE .NEW-T .ZERO <2 .ITM>>)
  75                   (<AND <OR <==? <1 .ITM> ADDI> <==? <1 .ITM> SUBI>>
  76                         <==? <3 .ITM> 1>
  77                         <==? <LENGTH .ITM> 3>
  78                         <NOT <EMPTY? <REST .NEW-T>>>
  79                         <TYPE? <SET NXT <2 .NEW-T>> INST>>
  80                    <COND (<==? <1 .NXT> JRST>
  81                           <NEW-INST .NEW-T
  82                                     <COND (<==? <1 .ITM> ADDI> AOJA) (T SOJA)>
  83                                     .ITM
  84                                     .NXT
  85                                     2>
  86                           <PUT .NEW-T 1 <CHTYPE .ITM OLD-AND-USELESS>>)
  87                          (<AND <SET TMP
  88                                     <MEMQ <1 .NXT>
  89                                           '[JUMPL
  90                                             JUMPGE
  91                                             JUMPLE
  92                                             JUMPG
  93                                             JUMPE
  94                                             JUMPN]>>
  95                                <==? <2 .NXT> <2 .ITM>>>
  96                           <NEW-INST .NEW-T
  97                                     <COND (<==? <1 .ITM> ADDI>
  98                                            <NTH '[AOJN
  99                                                   AOJE
 100                                                   AOJG
 101                                                   AOJLE
 102                                                   AOJGE
 103                                                   AOJL]
 104                                                 <LENGTH .TMP>>)
 105                                           (T
 106                                            <NTH '[SOJN
 107                                                   SOJE
 108                                                   SOJG
 109                                                   SOJLE
 110                                                   SOJGE
 111                                                   SOJL]
 112                                                 <LENGTH .TMP>>)>
 113                                     .ITM
 114                                     .NXT
 115                                     3>
 116                           <PUT .NEW-T 1 <CHTYPE .ITM OLD-AND-USELESS>>)>)>
 117             <COND (<NOT <TYPE? <1 .NEW-T> OLD-AND-USELESS>>
 118                    <SET PREPREV .PREVIOUS>
 119                    <SET PREVIOUS <1 .NEW-T>>)>>
 120     .T>
 121    <UNLABEL-THIS-TUPLE .CODE-L .T>
 122    <PRINTTYPE REF ,PRINT>
 123    .CODE-L>
 124
 125 <DEFINE NEW-INST (NEW-T NEW-OP CINST NXTINST BASE "AUX" NEW REFQ)
 126         #DECL ((NEW-T) <PRIMTYPE VECTOR> (NEW-OP) ATOM
 127                (CINST NXTINST) INST (BASE) FIX)
 128         <COND (<G? <LENGTH .NXTINST> .BASE>                           ;"JRST @"
 129                <SET NEW
 130                     <IVECTOR <+ <LENGTH .CINST> <- <LENGTH .NXTINST> .BASE>>>>
 131                <SUBSTRUC .CINST 0 <- <LENGTH .CINST> 1> .NEW>
 132                <SUBSTRUC .NXTINST
 133                          <- .BASE 1>
 134                          <- <LENGTH .NXTINST> <- .BASE 1>>
 135                          <REST .NEW <- <LENGTH .CINST> 1>>>
 136                <2 .NEW-T <SET CINST <CHTYPE .NEW INST>>>)
 137               (T <3 .CINST <NTH .NXTINST .BASE>> <2 .NEW-T .CINST>)>
 138         <COND (<AND <TYPE? <SET REFQ <NTH .CINST <LENGTH .CINST>>> REF>
 139                     <G=? <LENGTH .REFQ> 3>>
 140                <MAPR <>
 141                      <FUNCTION (RL "AUX" (I <1 .RL>))
 142                              <COND (<==? .I .NXTINST> <PUT .RL 1 .CINST>)>>
 143                      <CHTYPE <3 .REFQ> LIST>>)>
 144         <1 .CINST .NEW-OP>>
 145
 146 ;
 147 " Generate-circular-references makes labels be circular objects.
 148    First all the tags are found and a dummy reference shell is created.
 149    Then for all the lines which contain references, one links up the code
 150    and outputs the circular lines."
 151
 152 <DEFINE GENERATE-CIRCULAR-REFERENCES (TUP "AUX" TAGS)
 153   #DECL ((TUP) <PRIMTYPE VECTOR> (TAGS) LIST)
 154   <SET TAGS
 155        <MAPF ,LIST
 156              <FUNCTION (ITEM)
 157                #DECL ((ITEM) LAB)
 158                <MAPRET <LAB-NAM .ITEM> <CHTYPE [<LAB-NAM .ITEM> T '()] REF>>>
 159              ,LABELS>>
 160   <MAPR <>
 161         <FUNCTION (CODE "AUX"
 162                         (LINE <1 .CODE>)      ;"Current line"
 163                         LAST                  ;"Last item in current line"
 164                         LL                    ;"Reference list segment"
 165                         NEW-REF)              ;"New reference"
 166           #DECL ((CODE) <PRIMTYPE VECTOR> (LINE) <OR INST REF ATOM>
 167                  (LAST) <OR LIST REF ATOM FIX CHARACTER> (LL) <OR LIST FALSE>
 168                  (NEW-REF) REF)
 169           <COND (<AND <TYPE? .LINE INST>
 170                       <OR
 171                        <AND <TYPE? <SET LAST <NTH .LINE <LENGTH .LINE>>> REF>
 172                             <SET LL <MEMQ <1 .LAST> .TAGS>>>
 173                        <AND <==? <1 .LINE> DISPATCH>
 174                             <SET LL <MEMQ <2 .LINE> .TAGS>>>
 175                        <AND <TYPE? <1 .LINE> GFRM SGFRM SBFRM>
 176                             <SET LL <MEMQ <CHTYPE <1 .LINE> ATOM> .TAGS>>>>>
 177                  <SET NEW-REF <2 .LL>>
 178                  <PUT .NEW-REF 3 (.LINE !<3 .NEW-REF>)>
 179                  <PUT .LINE <LENGTH .LINE> .NEW-REF>
 180                  <COND (<TYPE? <1 .LINE> GFRM SGFRM SBFRM>
 181                         <PUT .LINE 1 <CHTYPE <1 .NEW-REF> <TYPE <1 .LINE>>>>)>)
 182                 (<AND <TYPE? .LINE ATOM>
 183                       <SET LL <MEMQ .LINE .TAGS>>>
 184                  <PUT .CODE 1 <2 .LL>>)
 185                 (<TYPE? .LINE ATOM>           ;"Reference which was deleted"
 186                  <PUT .CODE 1 <CHTYPE [.LINE] OLD-AND-USELESS>>)>>
 187           .TUP>>
 188
 189 ;"Delete-adjacent-refs will delete the first reference of a pair of references
 190   next to each other and call itself recursively."
 191
 192 <DEFINE DELETE-ADJACENT-REFS (TUP "AUX" (ITM <1 .TUP>) (NXT <2 .TUP>) USELESS)
 193   #DECL ((TUP) <PRIMTYPE VECTOR> (NXT) <OR OLD-AND-USELESS REF INST> (ITM) REF)
 194   <REPEAT ()
 195           <COND (<TYPE? .NXT REF>;"Deletes adjacent ref"
 196                  <MAPF <>
 197                        <FUNCTION (INS)
 198                             #DECL ((INS) INST)
 199                             <PUT .ITM 3 (.INS !<3 .ITM>)>
 200                             <COND (<TYPE? <1 .INS> GFRM SGFRM SBFRM>
 201                                    <PUT .INS 1
 202                                         <CHTYPE <1 .ITM> <TYPE <1 .INS>>>>)>
 203                             <PUT .INS <LENGTH .INS> .ITM>>
 204                        <CHTYPE <3 .NXT> LIST>>
 205                  <PUT .TUP 2 .ITM>
 206                  <PUT .TUP 1 <CHTYPE [<1 .NXT>] OLD-AND-USELESS>>
 207                  <COND (<EMPTY? <SET TUP <REST .TUP>>> <RETURN>)>
 208                  <SET NXT <2 .TUP>>)
 209                 (ELSE
 210                  <RETURN>)>>>
 211
 212 <DEFINE PUSH-OPTIMIZE (NEW-T ZERO AC "AUX" (COUNT 0)(AC2 T*))
 213         #DECL ((COUNT) FIX (AC AC2) ATOM (NEW-T) <PRIMTYPE VECTOR>)
 214         <COND (<==? .AC .AC2><SET AC2 B1*>)>
 215         <MAPR <>
 216               <FUNCTION (TUP "AUX" (LINE <1 .TUP>) C)
 217                    #DECL ((TUP) <PRIMTYPE VECTOR>
 218                           (LINE) <OR INST OLD-AND-USELESS REF>)
 219                    <COND (<AND <==? <1 .LINE> PUSH>
 220                                <==? <2 .LINE> .AC>
 221                                <TYPE? <SET C <3 .LINE>> REF>
 222                                <==? <1 .C> .ZERO>>
 223                           <SET COUNT <+ .COUNT 1>>)
 224                          (ELSE <MAPLEAVE>)>>
 225               .NEW-T>
 226   <COND (<G=? .COUNT 5>
 227          <PUT .NEW-T 1 <CHTYPE [XMOVEI .AC2 2  (.AC)] INST>>
 228          <PUT .NEW-T 2 <CHTYPE [ADJSP  .AC   .COUNT] INST>>
 229          <PUT .NEW-T 3 <CHTYPE [SETZM   -1    (.AC2)] INST>>
 230          <PUT .NEW-T 4 <CHTYPE [HRLI   .AC2 -1 (.AC2)] INST>>
 231          <PUT .NEW-T 5 <CHTYPE [BLT    .AC2    (.AC)] INST>>
 232          <REPEAT ((CNT <- .COUNT 4>)
 233                   (TUP <REST .NEW-T 5>))
 234            #DECL ((CNT) FIX (TUP) <PRIMTYPE VECTOR> (ZRO) OLD-AND-USELESS)
 235            <COND (<0? <SET CNT <- .CNT 1>>><RETURN>)
 236                  (ELSE <PUT .TUP 1 <ELIMINATE <1 .TUP>>>
 237                        <SET TUP <REST .TUP>>)>>)>>
 238
 239 <DEFINE SKIP-MODIFY (NEW-T PREVIOUS PREPREV
 240                      "AUX" (ITM <1 .NEW-T>)
 241                            (NEXTLINE
 242                             <AND <NOT <EMPTY? <REST .NEW-T>>> <2 .NEW-T>>) OPP
 243                            FOO)
 244         #DECL ((NEW-T) <PRIMTYPE VECTOR> (ITM) INST
 245                (PREVIOUS NEXTLINE) <OR OLD-AND-USELESS INST REF FALSE>)
 246         <COND (<AND .NEXTLINE
 247                     .PREVIOUS
 248                     <NOT <EMPTY? <REST .NEW-T 2>>>
 249                     <NOT <TYPE? .ITM OLD-AND-USELESS>>
 250                     <OR <==? <SET FOO <NTH .ITM <LENGTH .ITM>>> <3 .NEW-T>>
 251                         <==? .FOO .NEXTLINE>>>
 252                <COND (<AND <CONDITIONAL-SKIP? .PREVIOUS>
 253                            <UNCONDITIONAL-BRANCH? .NEXTLINE>
 254                            <OR <NOT .PREPREV>
 255                                <NOT <CONDITIONAL-SKIP? .PREPREV>>>
 256                            <SET OPP <GETPROP <1 .PREVIOUS> OPPOSITE>>>
 257                       <PUT .PREVIOUS 1 .OPP>
 258                       <PUT .NEW-T 1 <ELIMINATE <1 .NEW-T>>>)
 259                      (<TYPE? .NEXTLINE REF OLD-AND-USELESS>
 260                       <PUT .NEW-T 1 <ELIMINATE .ITM>>)
 261                      (ELSE <PUT .NEW-T 1 <CHTYPE [CAIA A1* A1*] INST>>)>)>>
 262
 263 <DEFINE UNLABEL-THIS-TUPLE (L T "AUX" RF)
 264   #DECL ((T) <PRIMTYPE VECTOR> (RF) ANY (L) LIST)
 265   <AND ,PEEP-CHANNEL <CRLF ,PEEP-CHANNEL>>
 266   <MAPF <>
 267         <FUNCTION (STATEMENT)
 268              #DECL ((STATEMENT) <OR INST REF OLD-AND-USELESS>)
 269              <COND (<TYPE? .STATEMENT REF>
 270                     <COND (,PEEP-CHANNEL <PRINT <1 .STATEMENT> ,PEEP-CHANNEL>)>
 271                     <PUT <SET L <REST .L>> 1 <1 .STATEMENT>>)
 272                    (<TYPE? .STATEMENT OLD-AND-USELESS>
 273                     <COND (,PEEP-CHANNEL <PRINT .STATEMENT ,PEEP-CHANNEL>)>)
 274                    (<AND <TYPE? .STATEMENT INST>
 275                          <==? <1 .STATEMENT> DISPATCH>
 276                          <TYPE? <SET RF <2 .STATEMENT>> REF>>
 277                     <PUT .STATEMENT 2 <1 .RF>>
 278                     <COND (,PEEP-CHANNEL <PRINT .STATEMENT ,PEEP-CHANNEL>)>
 279                     <PUT <SET L <REST .L>> 1 .STATEMENT>)
 280                    (<AND <TYPE? .STATEMENT INST>
 281                          <TYPE?
 282                           <SET RF <NTH .STATEMENT <LENGTH .STATEMENT>>>
 283                           REF>>
 284                      <COND (<TYPE? <1 .STATEMENT> SGFRM GFRM SBFRM>
 285                             <PUT .STATEMENT <LENGTH .STATEMENT> T>)
 286                            (ELSE
 287                             <PUT .STATEMENT <LENGTH .STATEMENT>
 288                                  <CHTYPE [<1 .RF>] REF>>)>
 289                      <COND (,PEEP-CHANNEL
 290                            <PRINT .STATEMENT ,PEEP-CHANNEL>)>
 291                     <PUT <SET L <REST .L>> 1 .STATEMENT>)
 292                    (ELSE
 293                     <COND (,PEEP-CHANNEL <PRINT .STATEMENT ,PEEP-CHANNEL>)>
 294                     <PUT <SET L <REST .L>> 1 .STATEMENT>)>>
 295         .T>
 296   <PUTREST .L ()>>
 297
 298 <DEFINE POST-ACCESS (BACK0 TUP "AUX" (BACK1 <1 <SET TUP <BACK .TUP>>>)
 299                                      (BACK2 <1 <BACK .TUP>>))
 300   #DECL ((TUP) <PRIMTYPE VECTOR>
 301          (BACK0 BACK1 BACK2) <OR FALSE INST REF OLD-AND-USELESS>)
 302   <COND (<TYPE? .BACK0 OLD-AND-USELESS>
 303          <POST-ACCESS .BACK0 <BACK .TUP>>)
 304         (<OR <NOT <UNCONDITIONAL-BRANCH? .BACK1>>
 305              <CONDITIONAL-SKIP? .BACK2>
 306              <UNCONDITIONAL-SKIP? .BACK2>
 307              <AND <OR <CONDITIONAL-BRANCH? .BACK2>
 308                       <UNCONDITIONAL-BRANCH? .BACK2>>
 309                   <==? .BACK0 <NTH .BACK2 <LENGTH .BACK2>>>>>)
 310         (ELSE <PUT .BACK0 2 <>>)>>
 311
 312 <DEFINE CONDITIONAL-BRANCH? (ITEM)
 313   #DECL ((ITEM) <OR OLD-AND-USELESS INST REF>)
 314   <MEMQ <1 .ITEM> ,CJ-JUMP-LIST>>
 315
 316 <DEFINE CONDITIONAL-SKIP? (ITEM)
 317   #DECL ((ITEM) <OR OLD-AND-USELESS INST REF>)
 318   <MEMQ <1 .ITEM> ,CS-JUMP-LIST>>
 319
 320 <DEFINE UNCONDITIONAL-BRANCH? (ITEM "AUX" LBL)
 321   #DECL ((ITEM) <OR OLD-AND-USELESS INST REF>)
 322   <AND <MEMQ <1 .ITEM> ,UJ-JUMP-LIST>
 323        <TYPE? <SET LBL <NTH .ITEM <LENGTH .ITEM>>> REF>
 324        <N==? <1 .LBL> COMPERR>>>
 325
 326 <DEFINE UNCONDITIONAL-SKIP? (ITEM)
 327   #DECL ((ITEM) <OR OLD-AND-USELESS INST REF>)
 328   <==? <1 .ITEM> CAIA>>
 329
 330 <DEFINE JUMP? (INSTR)
 331   #DECL ((INSTR) <OR OLD-AND-USELESS INST REF>)
 332   <OR <CONDITIONAL-BRANCH? .INSTR>
 333       <CONDITIONAL-SKIP? .INSTR>
 334       <UNCONDITIONAL-BRANCH? .INSTR>
 335       <UNCONDITIONAL-SKIP? .INSTR>>>
 336
 337 <GDECL (UJ-JUMP-LIST US-JUMP-LIST CJ-JUMP-LIST CS-JUMP-LIST)
 338        <LIST [REST ATOM]>
 339        (JUMP-LIST)
 340        !<LIST [4 <LIST [REST ATOM]>]>>
 341
 342 <SETG JUMP-LIST
 343       (<SETG UJ-JUMP-LIST '(JUMPA AOJA SOJA JRST PUSHJ JSP UJ)>
 344        <SETG US-JUMP-LIST '(CAIA SKIPA AOSA SOSA US)>
 345        <SETG CJ-JUMP-LIST
 346              '(JUMPL
 347                JUMPGE
 348                JUMPE
 349                JUMPN
 350                JUMPLE
 351                JUMPG
 352                SOJL
 353                SOJGE
 354                SOJE
 355                SOJN
 356                SOJLE
 357                SOJG
 358                CJ)>
 359        <SETG CS-JUMP-LIST
 360              '(CAIL
 361                CAIGE
 362                CAIE
 363                CAIN
 364                CAILE
 365                CAIG
 366                CAML
 367                CAMGE
 368                CAME
 369                CAMN
 370                CAMLE
 371                CAMG
 372                SOSL
 373                SOSGE
 374                SOSE
 375                SOSN
 376                SOSLE
 377                SOSG
 378                AOSL
 379                AOSGE
 380                AOSE
 381                AOSN
 382                AOSLE
 383                AOSG
 384                SKIPL
 385                SKIPGE
 386                SKIPE
 387                SKIPN
 388                SKIPLE
 389                SKIPG
 390                TRNE
 391                TRNN
 392                TLNN
 393                TLNE
 394                CS)>)>
 395
 396 <DEFINE MAKE-OPPOSITES (ITEM-1 ITEM-2)
 397   #DECL ((ITEM-1 ITEM-2) ATOM)
 398   <PUTPROP .ITEM-1 OPPOSITE .ITEM-2>
 399   <PUTPROP .ITEM-2 OPPOSITE .ITEM-1>>
 400
 401 <DEFINE SINGLE-PATH-OPTIMIZE (TOP-OF-TUP NEW-T
 402                               "AUX" (BACKREG-LIST '())
 403                                     (LBL <1 .NEW-T>)
 404                                     (ACS '(A1* A2* B1* B2* C1*
 405                                                C2* T*  X*  O*)))
 406   #DECL ((BACKREG-LIST ACS) LIST (TOP-OF-TUP NEW-T) <PRIMTYPE VECTOR>
 407          (LBL) <OR INST OLD-AND-USELESS REF>)
 408   <REPEAT ((STATEMENT <1 <3 .LBL>>)(NTUP <MEMQ .STATEMENT .TOP-OF-TUP>) ACC?)
 409     #DECL ((STATEMENT) <OR INST REF OLD-AND-USELESS>
 410            (NTUP) <OR FALSE <PRIMTYPE VECTOR>> (ACC?) <OR REF ATOM FIX LIST>)
 411     <COND (<OR <TYPE? .STATEMENT REF>
 412                <AND <TYPE? .STATEMENT INST>
 413                     <OR <==? <1 .STATEMENT> PUSHJ>
 414                         <==? <1 .STATEMENT> JSP>>>>
 415            <RETURN>)
 416           (<AND <MOVE? .STATEMENT>
 417                 <MEMQ <SET ACC? <2 .STATEMENT>> .ACS>
 418                 <NOT <MEMQ .ACC? .BACKREG-LIST>>>
 419            <SET ACS <MAPR ,LIST
 420                           <FUNCTION (ACLIST "AUX" (AC <1 .ACLIST>))
 421                             #DECL ((ACLIST) LIST (AC) ATOM)
 422                             <COND (<==? .ACC? .AC><MAPSTOP !<REST .ACLIST>>)
 423                                   (ELSE <MAPRET .AC>)>>
 424                           .ACS>>
 425            <SET BACKREG-LIST (.ACC? .STATEMENT !.BACKREG-LIST)>)
 426           (<AND <G? <LENGTH .STATEMENT> 1>
 427                 <TYPE? <SET ACC? <2 .STATEMENT>> ATOM>
 428                 <MEMQ .ACC? .ACS>>
 429            <SET ACS <MAPR ,LIST
 430                           <FUNCTION (ACLIST "AUX" (AC <1 .ACLIST>))
 431                             #DECL ((ACLIST) LIST (AC) ATOM)
 432                             <COND (<==? .ACC? .AC><MAPSTOP !<REST .ACLIST>>)
 433                                   (ELSE <MAPRET .AC>)>>
 434                           .ACS>>)>
 435     <COND (<OR <NOT .NTUP> <==? .NTUP .TOP-OF-TUP>><RETURN>)
 436           (ELSE <SET STATEMENT <1 <SET NTUP <BACK .NTUP>>>>)>>
 437   <SET ACS '()>
 438   <MAPR <>
 439         <FUNCTION (NTUP "AUX" (STATEMENT <1 .NTUP>) STM)
 440           #DECL ((NTUP) <PRIMTYPE VECTOR>
 441                  (STATEMENT) <OR INST OLD-AND-USELESS REF>)
 442           <COND (<JUMP? .STATEMENT><MAPLEAVE>)
 443                 (<TYPE? .STATEMENT REF><MAPLEAVE>)
 444                 (<AND <MOVE? .STATEMENT>
 445                       <NOT <MEMQ <2 .STATEMENT> .ACS>>
 446                       <SET STM <MEMQ .STATEMENT .BACKREG-LIST>>>
 447                  <SET ACS (<2 .STATEMENT> !.ACS)>
 448                  <PUT .STM 1 <ELIMINATE <1 .STM>>>
 449                  <PUT .NTUP 1 <ELIMINATE <1 .NTUP>>>)
 450                 (<MOVE? .STATEMENT>
 451                  <SET ACS (<2 .STATEMENT> !.ACS)>)>>
 452         <REST .NEW-T>>>
 453
 454 <DEFINE MOVE? (ITM)
 455   #DECL ((ITM) <OR INST REF OLD-AND-USELESS>)
 456   <AND <TYPE? .ITM INST>
 457        <MEMQ <1 .ITM> '[MOVE DMOVE MOVSI MOVEI MOVNI]>
 458        <IS-REAL-AC? <2 .ITM>>>>
 459
 460 <DEFINE FINDZERO ()
 461   <REPEAT ((NCV ,CONSTANT-VECTOR))
 462     #DECL ((NCV) LIST)
 463     <COND (<EMPTY? .NCV><RETURN <>>)
 464           (<==? <CB-VAL <1 .NCV>> #CONSTANT *000000000000*>
 465            <RETURN <1 .NCV>>)
 466           (ELSE <SET NCV <REST .NCV>>)>>>
 467
 468 <DEFINE MOVE-CHECK (NEW-T LINE
 469                     "AUX" (LABEL <1 .LINE>) (DESTINATION <2 .LINE>)
 470                           DESTINATION2
 471                           (SOURCE <AND <TYPE? <3 .LINE> ATOM> <3 .LINE>>)
 472                           SOURCE2 USEFUL-CODE)
 473    #DECL ((LINE) INST (LABEL) ATOM (NEW-T) <PRIMTYPE VECTOR>
 474           (DESTINATION SOURCE) <OR ATOM FIX FALSE LIST>
 475           (SOURCE2 DESTINATION2) <OR FALSE ATOM> (USEFUL-CODE) LIST)
 476    <COND
 477     (<AND <IS-REAL-AC? .DESTINATION> .SOURCE <IS-REAL-AC? .SOURCE>>
 478      <SET USEFUL-CODE
 479           <MAPR ,LIST
 480                 <FUNCTION (NEW-TUP "AUX" (LINE <1 .NEW-TUP>))
 481                         #DECL ((LINE) <OR INST REF OLD-AND-USELESS>)
 482                         <COND (<TYPE? .LINE REF>
 483                                <COND (<L-LOOP? .NEW-TUP> <MAPLEAVE '()>)
 484                                      (ELSE <MAPSTOP>)>)
 485                               (<CONDITIONAL-BRANCH? .LINE>
 486                                <MAPLEAVE ()>)
 487                               (<UNCONDITIONAL-BRANCH? .LINE>
 488                                <MAPSTOP .LINE>)
 489                               (<OR <AND <==? <1 .LINE> JRST> <==? <2 .LINE> @>>
 490                                    <==? <1 .LINE> PUSHJ>
 491                                    <==? <1 .LINE> JSP>>
 492                                <MAPLEAVE '()>)
 493                               (ELSE <MAPRET .LINE>)>>
 494                 <REST .NEW-T>>>
 495      <COND (<EMPTY? .USEFUL-CODE>)
 496            (<AND <==? .LABEL MOVE>
 497                  <NOT <IS-THIS-AC-USED? .SOURCE .USEFUL-CODE .DESTINATION>>>
 498             <REPLACE-ACS .SOURCE .DESTINATION .USEFUL-CODE>
 499             <PUT .NEW-T 1 <ELIMINATE <1 .NEW-T>>>)
 500            (<AND <==? .LABEL DMOVE>
 501                  <SET SOURCE2 <GETPROP .SOURCE AC-PAIR>>
 502                  <SET DESTINATION2 <GETPROP .DESTINATION AC-PAIR>>
 503                  <NOT <IS-THIS-AC-USED? .SOURCE .USEFUL-CODE .DESTINATION>>
 504                  <NOT <IS-THIS-AC-USED? .SOURCE2 .USEFUL-CODE .DESTINATION2>>>
 505             <REPLACE-ACS .SOURCE .DESTINATION .USEFUL-CODE>
 506             <REPLACE-ACS .SOURCE2 .DESTINATION2 .USEFUL-CODE>
 507             <PUT .NEW-T 1 <ELIMINATE <1 .NEW-T>>>)>)>>
 508
 509 <DEFINE REPLACE-ACS (AC1 AC2 CODE "AUX" (LAC1 (.AC1)) (LAC2 (.AC2)))
 510         #DECL ((AC1 AC2) ATOM (LAC1 LAC2) LIST (CODE) LIST)
 511         <MAPF <>
 512               <FUNCTION (LINE "AUX" SUBSET)
 513                       #DECL ((LINE SUBSET)
 514                              <OR VECTOR INST REF OLD-AND-USELESS FALSE>)
 515                       <COND (<SET SUBSET <MEMBER .LAC2 .LINE>>
 516                              <PUT .SUBSET 1 .LAC1>)
 517                             (<MEMQ <1 .LINE> '[MOVE DMOVE]>)
 518                             (<SET SUBSET <MEMQ .AC2 .LINE>>
 519                              <PUT .SUBSET 1 .AC1>)>>
 520               .CODE>>
 521
 522 <DEFINE IS-THIS-AC-USED? (ACCUM CODE DEST
 523                                 "AUX" (ACCUM2 <GETPROP .ACCUM AC-PAIR>)(MOVED? <>)
 524                                 (LDEST (.DEST))
 525                                 (DEST2 <GETPROP .DEST AC-PAIR>)
 526                                 (LDEST2 <AND .DEST2 (.DEST2)>)
 527                                 (SRC-USED <>) (DST-USED <>) R)
 528   #DECL ((ACCUM) ATOM (CODE) LIST)
 529   <MAPF <>
 530         <FUNCTION (LINE)
 531           #DECL ((LINE) <OR INST REF OLD-AND-USELESS>)
 532           <COND (.MOVED?
 533                  <COND (<OR <MEMQ .DEST .LINE>
 534                             <MEMQ .LDEST .LINE>>
 535                         <MAPLEAVE T>)
 536                        (<AND .DEST2
 537                              <MEMQ .DEST2 .LINE>
 538                              <MEMQ .LDEST .LINE>>
 539                         <MAPLEAVE T>)
 540                        (ELSE <>)>)
 541                 (<AND <OR <MEMQ .ACCUM .LINE>
 542                           <AND .ACCUM2
 543                                <MEMQ .ACCUM2 .LINE>>>
 544                       <MEMQ <1 .LINE> '[DMOVEM MOVEM]>>
 545                  <COND (.DST-USED <MAPLEAVE T>) (ELSE <>)>)
 546                 (<AND <OR <MEMQ .DEST .LINE>
 547                           <AND .DEST2
 548                                <MEMQ .DEST2 .LINE>>>
 549                       <MEMQ <1 .LINE> '[DMOVEM MOVEM]>>
 550                  <COND (.SRC-USED <MAPLEAVE T>) (ELSE <>)>)
 551                 (<AND <OR <MEMQ .ACCUM .LINE>
 552                           <AND .ACCUM2
 553                                <MEMQ .ACCUM2 .LINE>>>
 554                       <MEMQ <1 .LINE> '[DMOVE MOVE MOVSI MOVEI MOVNI]>
 555                       <NOT <AND <TYPE? <SET R <NTH .LINE <LENGTH .LINE>>> LIST>
 556                                 <OR <==? <1 .R> .ACCUM>
 557                                     <==? <1 .R> .ACCUM2>>>>>
 558                  <SET MOVED? T>
 559                  <>)
 560                 (<OR <MEMQ .ACCUM .LINE>
 561                      <AND .ACCUM2 <MEMQ .ACCUM2 .LINE>>>
 562                  <COND (.DST-USED <MAPLEAVE T>)
 563                        (ELSE <SET SRC-USED T> <>)>)
 564                 (<OR <MEMQ .DEST .LINE>
 565                      <AND .DEST2 <MEMQ .DEST2 .LINE>>>
 566                  <COND (.SRC-USED <MAPLEAVE T>)
 567                        (ELSE <SET DST-USED T> <>)>)
 568                 (ELSE <>)>>
 569         .CODE>>
 570
 571 <DEFINE IS-REAL-AC? (ITEM)
 572   #DECL ((ITEM) ATOM)
 573   <MEMQ .ITEM '[A1* A2* B1* B2* C1* C2* X* T*]>>
 574
 575 <DEFINE MOVE-NEEDED? (NEW-T ITM
 576                       "AUX" (BOTH? <==? <1 .ITM> DMOVE>) (REG <2 .ITM>)
 577                             (INDEX (.REG)) AFT-SKIP
 578                             (REG2 <AND .BOTH? <GETPROP .REG AC-PAIR>>)
 579                             (INDEX2 <AND .BOTH? (.REG2)>))
 580    #DECL ((ITM) INST (BOTH) <OR FALSE T> (REG) ATOM (REG2) <OR FALSE ATOM>
 581           (INDEX2) <OR LIST FALSE> (NEW-T) <PRIMTYPE VECTOR>)
 582    <MAPR <>
 583     <FUNCTION (TT "AUX" (LINE <1 .TT>) (OP <1 .LINE>) F)
 584             #DECL ((TT) <PRIMTYPE VECTOR> (LINE) <OR INST REF OLD-AND-USELESS>
 585                    (F) ANY)
 586             <COND (<TYPE? .LINE REF>
 587                    <COND (<L-LOOP? .TT>)
 588                          (ELSE <PUT .NEW-T 1 <ELIMINATE <1 .NEW-T>>>)>
 589                    <MAPLEAVE>)
 590                   (<OR <==? .OP PUSHJ>
 591                        <==? .OP JSP>
 592                        <AND <==? .OP JRST> <==? <2 .LINE> @>>
 593                        <AND <==? .OP LDB>
 594                             <LDB-REGISTER-USED? .LINE .REG .REG2>>>
 595                    <MAPLEAVE>)
 596                   (<AND <MEMQ <1 .LINE> [DMOVE MOVE MOVNI MOVSI MOVEI]>
 597                         <==? <2 .LINE> .REG>
 598                         <=? .LINE .ITM>
 599                         <OR <NOT <TYPE? <SET F <NTH .LINE <LENGTH .LINE>>>
 600                                         LIST>>
 601                             <N==? <1 .F> .REG>>>
 602                    <SET AFT-SKIP <>>
 603                    <PUT .TT 1 <ELIMINATE <1 .TT>>>)
 604                   (<MEMBER .INDEX .LINE> <MAPLEAVE>)
 605                   (<AND <==? .OP MOVEM> <MEMQ .REG .LINE>>
 606                    <COND (<AND <TYPE? <3 .LINE> LOCAL-NAME>
 607                                <=? <REST .LINE 2> <REST .ITM 2>>>
 608                           <PUT .NEW-T 1 <ELIMINATE <1 .NEW-T>>>
 609                           <PUT .TT 1 <ELIMINATE <1 .TT>>>)>
 610                    <MAPLEAVE>)
 611                   (<AND <==? .OP DMOVEM>
 612                         <SET REG2 <GETPROP .REG AC-PAIR>>
 613                         <MEMQ .REG2 .LINE>>
 614                    <MAPLEAVE>)
 615                   (<AND <UNCONDITIONAL-BRANCH? .LINE>
 616                         <NOT .AFT-SKIP>>
 617                    <PUT .NEW-T 1 <ELIMINATE <1 .NEW-T>>>
 618                    <MAPLEAVE>)
 619                   (<OR <AND .BOTH?
 620                             <OR <MEMQ .REG2 .LINE> <MEMBER .INDEX2 .LINE>>>
 621                        <MEMQ .REG .LINE>>
 622                    <MAPLEAVE>)
 623                   (<OR <CONDITIONAL-SKIP? .LINE>
 624                        <UNCONDITIONAL-SKIP? .LINE>>
 625                    <SET AFT-SKIP T>)
 626                   (ELSE
 627                    <SET AFT-SKIP <>>)>>
 628     <REST .NEW-T>>>
 629
 630 <DEFINE BRANCH-CHAIN (NEW-T "AUX" (TAG1 <1 .NEW-T>)(JUMP1 <2 .NEW-T>)
 631                                   (TAG2 <NTH .JUMP1 <LENGTH .JUMP1>>)
 632                                   (FLUSHIT T))
 633   #DECL ((NEW-T) <PRIMTYPE VECTOR> (TAG1 TAG2) REF (JUMP1) INST)
 634   <MAPF <>
 635         <FUNCTION (LINE) #DECL ((LINE) INST)
 636           <COND (<TYPE? <1 .LINE> SGFRM>
 637                  <SET FLUSHIT <>>)
 638                 (ELSE
 639                  <COND (<TYPE? <1 .LINE> GFRM SBFRM>
 640                         <PUT .LINE 1 <CHTYPE <1 .TAG2> <TYPE <1 .LINE>>>>)>
 641                  <PUT .LINE <LENGTH .LINE> .TAG2>
 642                  <PUT .TAG2 3 (.LINE !<3 .TAG2>)>)>>
 643         <3 .TAG1>>
 644   <COND (.FLUSHIT
 645          <PUT .NEW-T 1 <CHTYPE [<1 .TAG1>] OLD-AND-USELESS>>
 646          <COND (<AND <UNCONDITIONAL-BRANCH? <1 <BACK .NEW-T>>>
 647                      <NOT <CONDITIONAL-SKIP? <1 <BACK .NEW-T 2>>>>>
 648                 <PUT .NEW-T 2 <ELIMINATE <2 .NEW-T>>>)>)>>
 649
 650
 651 <DEFINE LDB-REGISTER-USED? (ITM REG1 REG2 "AUX" (CNST <AND <TYPE? <3 .ITM> REF>
 652                                                            <1 <3 .ITM>>>)
 653                             CONSTANT FIELD1 FIELD2 CONSTANT-THING)
 654   #DECL ((ITM) INST (REG1) ATOM (REG2) <OR FALSE ATOM>
 655          (CNST) <OR CONSTANT-LABEL FALSE>
 656          (CONSTANT CONSTANT-THING) ANY (FIELD1 FIELD2) FIX)
 657   <COND (<AND <SET CONSTANT <MEMQ .CNST ,CONSTANT-VECTOR>>
 658               <SET CONSTANT-THING <2 .CONSTANT>>
 659               <TYPE? .CONSTANT-THING CONSTANT>
 660               <SET FIELD1 <CHTYPE <GETBITS .CONSTANT-THING <BITS 4 18>> FIX>>
 661               <SET FIELD2 <CHTYPE <GETBITS .CONSTANT-THING <BITS 14 0>> FIX>>>
 662          <OR <==? .FIELD1 <2 <MEMQ .REG1 ,ACS>>>
 663              <AND .REG2 <==? .FIELD1 <2 <MEMQ .REG2 ,ACS>>>>
 664              <AND <0? .FIELD1>
 665                   <L? .FIELD2 16>>>)
 666
 667         (ELSE T)>>
 668
 669 <PUTPROP A1* AC-PAIR A2*>
 670
 671 <PUTPROP A2* AC-PAIR A1*>
 672
 673 <PUTPROP B1* AC-PAIR B2*>
 674
 675 <PUTPROP B2* AC-PAIR B1*>
 676
 677 <PUTPROP C1* AC-PAIR C2*>
 678
 679 <PUTPROP C2* AC-PAIR C1*>
 680
 681 <DEFINE L-LOOP? (TUP "AUX" (LAB <1 .TUP>))
 682   #DECL ((TUP) <PRIMTYPE VECTOR>)
 683   <MAPR <>
 684         <FUNCTION (NEWTUP "AUX" (LINE <1 .NEWTUP>))
 685           <COND (<TYPE? .LINE REF>
 686                  <MAPLEAVE <>>)
 687                 (<MEMQ .LAB .LINE>
 688                  <MAPLEAVE T>)>>
 689         <REST .TUP>>>
 690
 691 <SETG CIRC-LOOP? <>>
 692
 693 <DEFINE ELIMINATE (STATEMENT "AUX" LAST)
 694         <COND (<AND <TYPE? .PREVIOUS INST>
 695                     <CONDITIONAL-SKIP? .PREVIOUS>
 696                     <MOVE? .STATEMENT>>
 697                <PUT .PREVIOUS 1 MOVE>)>
 698         <COND (<TYPE? .STATEMENT REF>
 699                <PUT .STATEMENT 3 '()>
 700                <CHTYPE [<1 .STATEMENT>] OLD-AND-USELESS>)
 701               (<AND <TYPE? .STATEMENT INST>
 702                     <TYPE? <SET LAST <NTH .STATEMENT <LENGTH .STATEMENT>>> REF>
 703                     <==? <LENGTH .LAST> 3>
 704                     <TYPE? <3 .LAST> LIST>>
 705                <PUT .LAST
 706                     3
 707                     <MAPF ,LIST
 708                           <FUNCTION (LINE)
 709                                   <COND (<==? .LINE .STATEMENT> <MAPRET>)
 710                                         (ELSE <MAPRET .LINE>)>>
 711                           <3 .LAST>>>
 712                <PUT .STATEMENT <LENGTH .STATEMENT> <CHTYPE [<1 .LAST>] REF>>
 713                <CHTYPE .STATEMENT OLD-AND-USELESS>)
 714               (ELSE <CHTYPE .STATEMENT OLD-AND-USELESS>)>>
 715
 716
 717 <PROG ()
 718       <MAKE-OPPOSITES CAIGE CAIL>
 719       <MAKE-OPPOSITES CAIN CAIE>
 720       <MAKE-OPPOSITES CAIG CAILE>
 721       <MAKE-OPPOSITES CAMGE CAML>
 722       <MAKE-OPPOSITES CAMN CAME>
 723       <MAKE-OPPOSITES CAMG CAMLE>
 724       <MAKE-OPPOSITES SKIPLE SKIPG>
 725       <MAKE-OPPOSITES SKIPGE SKIPL>
 726       <MAKE-OPPOSITES SKIPN SKIPE>
 727       <MAKE-OPPOSITES TRNN TRNE>
 728       <MAKE-OPPOSITES TLNN TLNE>
 729       <MAKE-OPPOSITES JUMPGE JUMPL>
 730       <MAKE-OPPOSITES JUMPN JUMPE>
 731       <MAKE-OPPOSITES JUMPG JUMPLE>
 732       <MAKE-OPPOSITES SOJG SOJLE>
 733       <MAKE-OPPOSITES SOJL SOJGE>
 734       <MAKE-OPPOSITES SOJE SOJN>>