mim/development/mim/mimc/death.mud

   1 <PACKAGE "DEATH">
   2 "VERSION 1.4"
   3
   4 "This version written by CLR 2/85 based entirely on SAMs previous version.
   5  The differences are:
   6
   7         a)      Bit masks used instead of lists of names for efficiency.
   8
   9         b)      Attempt to flush dead SETs.
  10
  11 There are two interesting structures:
  12
  13         1)      Each temp atom's value is a uvector of fixes.
  14                         The first element is its number (starting at 0)
  15                         and increasing so each temp has a number.
  16
  17                         The rest of the elements are essentially constitute
  18                         a string of 1 bit bytes big enough for the total
  19                         number of temps.  The bit being on indicates a temp
  20                         that can't be merged with this one.
  21
  22         2)      The lists of live variables associated with branches is
  23                 also the same kind of bit string."
  24
  25
  26
  27 <ENTRY REMOVE-DEADS FIXUP-DEATH DEBUG-DEATH MAINTAIN-DECLS>
  28
  29 <USE "NEWSTRUC">
  30
  31 <SETG DEBUG-DEATH %<>>
  32 <SETG MAINTAIN-DECLS %<>>
  33
  34 "NAME-UV is a vector of temp names.  It is used to get from a number back to
  35  the name of a temp.  NOTE:  temp values start at 0 so 1 always must be added
  36  to index into this vector."
  37
  38 <GDECL (NAME-UV) <VECTOR [REST ATOM]> (UVSIZE) FIX>
  39
  40 <NEWTYPE DEAD-VAR ATOM>
  41
  42 <NEWSTRUC LABEL         VECTOR
  43           L-INST        <OR ATOM FORM>
  44           L-INS         <LIST [REST FIX]>
  45           L-LEVEL       FIX
  46           L-ASSIGN      <OR FALSE <LIST [REST !<LIST ATOM FIX>]>>>
  47
  48 <NEWSTRUC BRANCH        VECTOR
  49           B-INST        FORM
  50           B-OUTS        <LIST [REST FIX]>
  51           B-LIVES       UVECTOR
  52           B-FALL-DEADS  UVECTOR
  53           B-JUMP-DEADS  <OR FALSE UVECTOR>>
  54
  55
  56 <DEFMAC /32 ('X) <FORM LSH .X -5>>
  57
  58 <DEFINE FIXUP-DEATH (CODE:LIST "AUX" (OUTCHAN .OUTCHAN))
  59    <COND (,DEBUG-DEATH
  60           <PRINTSTRING "Fixup-death: " .OUTCHAN>
  61           <PRIN1 <2 <1 .CODE>:FORM> .OUTCHAN>
  62           <CRLF .OUTCHAN>
  63           <PRINTSTRING "Removing deads" .OUTCHAN>
  64           <CRLF .OUTCHAN>)>
  65    <SETG ANY-FLUSHED-INS <>>
  66    <BIND ((CODELEN:FIX <REMOVE-DEADS .CODE>)
  67           (VCODE:<SPECIAL VECTOR> <IVECTOR .CODELEN>) (VC:VECTOR .VCODE)
  68           LOOP-LABELS:<LIST [REST LABEL]>)
  69       <MAPF <>
  70             <FUNCTION (X)
  71                  <COND (<AND <TYPE? .X FORM>
  72                              <NOT <EMPTY? .X>>
  73                              <==? <1 .X> `ENDIF>>
  74                         <PUT .VC 1 .X> ;"Note:  ENDIFs go in twice!"
  75                         <SET VC <REST .VC>>)>
  76                  <PUT .VC 1 .X>
  77                  <SET VC <REST .VC>>>
  78             .CODE>
  79       <COND (,DEBUG-DEATH
  80              <PRINTSTRING "Preparing labels and temps" .OUTCHAN>
  81              <CRLF .OUTCHAN>)>
  82       <SET LOOP-LABELS <PREPARE-LABELS-AND-TEMPS .VCODE>>
  83       <COND (,DEBUG-DEATH
  84              <PRINTSTRING "Preparing branches" .OUTCHAN>
  85              <CRLF .OUTCHAN>)>
  86       <PREPARE-BRANCHES .VCODE 1 .CODELEN .CODELEN ()>
  87       <COND (,DEBUG-DEATH
  88              <PRINTSTRING "Backwalking" .OUTCHAN>
  89              <CRLF .OUTCHAN>)>
  90       <REPEAT ((LEVEL 1))
  91          <COND (,DEBUG-DEATH
  92                 <PRINTSTRING "Pass " .OUTCHAN>
  93                 <PRIN1 .LEVEL .OUTCHAN>
  94                 <CRLF .OUTCHAN>)>
  95          <SETG SOMETHING-CHANGED %<>>
  96          <BACKWALK-FROM-LABEL .VCODE <NTH .VCODE .CODELEN> .LEVEL>
  97          <MAPF %<>
  98                <FUNCTION (LABEL:LABEL)
  99                   <BACKWALK-FROM-LABEL .VCODE .LABEL .LEVEL>>
 100                .LOOP-LABELS>
 101          <COND (<NOT ,SOMETHING-CHANGED>
 102                 <RETURN>)>
 103          <SET LEVEL <+ .LEVEL 1>>>
 104       <COND (,DEBUG-DEATH
 105              <PRINTSTRING "SET optimization" .OUTCHAN>
 106              <CRLF .OUTCHAN>)>
 107       <OPTIMIZE-SETS .VCODE>
 108       <COND (,DEBUG-DEATH
 109              <PRINTSTRING "General optimization" .OUTCHAN>
 110              <CRLF .OUTCHAN>)>
 111       <OPTIMIZE-TEMPS .VCODE>
 112       ;"This pass never seems to find anything it can merge."
 113       <COND (<NOT ,MAINTAIN-DECLS>
 114              <COND (,DEBUG-DEATH
 115                     <PRINTSTRING "Optional optimization pass (ignoring decls)"
 116                                  .OUTCHAN>
 117                     <CRLF .OUTCHAN>)>
 118              <OPTIMIZE-TEMPS/BASH-DECLS .VCODE>)>
 119       <COND (,DEBUG-DEATH
 120              <PRINTSTRING "Preparing deads" .OUTCHAN>
 121              <CRLF .OUTCHAN>)>
 122       <PREPARE-DEADS-FROM-LABEL .VCODE <NTH .VCODE .CODELEN>>
 123       <MAPF %<>
 124             <FUNCTION (LABEL:LABEL)
 125                <PREPARE-DEADS-FROM-LABEL .VCODE .LABEL>>
 126             .LOOP-LABELS>
 127       <COND (,DEBUG-DEATH
 128              <PRINTSTRING "Inserting deads" .OUTCHAN>
 129              <CRLF .OUTCHAN>)>
 130       <INSERT-DEADS .CODE .VCODE>>
 131    <COND (,DEBUG-DEATH
 132           <PRINTSTRING "Death complete: " .OUTCHAN>
 133           <PRIN1 <2 <1 .CODE>:FORM> .OUTCHAN>
 134           <CRLF .OUTCHAN>)>
 135    ,ANY-FLUSHED-INS>
 136
 137 "ADD-LIST ORs a bit into a uvector.  In the old world it addes an atom to
 138  a LIST."
 139
 140 <DEFINE ADD-LIST (ATM:ATOM L:UVECTOR "VALUE" UVECTOR
 141                   "AUX" (NUM:FIX <1 <GVAL .ATM>:UVECTOR>)
 142                         (WD:FIX <+ </32 .NUM> 1>) (BIT:FIX <MOD .NUM 32>))
 143         <PUT .L .WD <ORB <NTH .L .WD> <LSH 1 .BIT>>>>
 144
 145 "ADD-LIST? same as ADD-LIST except returns #FALSE () if already there."
 146
 147 <DEFINE ADD-LIST? (ATM:ATOM L:UVECTOR "VALUE" <OR FALSE UVECTOR>
 148                    "AUX" (NUM:FIX <1 <GVAL .ATM>:UVECTOR>) TEM:FIX
 149                          (WD:FIX <+ </32 .NUM> 1>) (BIT:FIX <MOD .NUM 32>))
 150         <COND (<==? <ANDB <SET TEM <NTH .L .WD>> <SET BIT <LSH 1 .BIT>>> 0>
 151                <PUT .L .WD <ORB .TEM .BIT>>)>>
 152
 153 "REM-LIST kill a bit in the uvector same way as ADD-LIST."
 154
 155 <DEFINE REM-LIST (ATM:ATOM L:UVECTOR
 156                   "AUX" (NUM:FIX <1 <GVAL .ATM>:UVECTOR>)
 157                         (WD:FIX <+ </32 .NUM> 1>) (BIT:FIX <MOD .NUM 32>))
 158         <PUT .L .WD <ANDB <NTH .L .WD>  <ROT <XORB 1 -1> .BIT>>>>
 159
 160 "REM-LIST? return false if not there, else remove it and return true"
 161
 162 <DEFINE REM-LIST? (ATM:ATOM L:UVECTOR
 163                    "AUX" (NUM:FIX <1 <GVAL .ATM>:UVECTOR>) TEM:FIX
 164                          (WD:FIX <+ </32 .NUM> 1>) (BIT:FIX <MOD .NUM 32>))
 165         <SET BIT <LSH 1 .BIT>>
 166         <COND (<N==? <ANDB <SET TEM <NTH .L .WD>> .BIT> 0>
 167                <PUT .L .WD <XORB .TEM .BIT>>)>>
 168
 169 "IN-LIST? see if bit is on"
 170
 171 <DEFINE IN-LIST? (ATM:ATOM L:UVECTOR "VALUE" <OR FALSE UVECTOR>
 172                   "AUX" (NUM:FIX <1 <GVAL .ATM>:UVECTOR>)
 173                         (WD:FIX <+ </32 .NUM> 1>) (BIT:FIX <MOD .NUM 32>))
 174         <COND (<==? <ANDB <NTH .L .WD> <LSH 1 .BIT>> 0> <>)
 175               (ELSE .L)>>
 176
 177 <DEFINE INTERSECT-LISTS (L1:<LIST [REST ATOM]> L2:<LIST [REST ATOM]>)
 178    ;"I know this isn't the most efficient way, but I'm too tired to figure
 179      it out now, and it doesn't get called much."
 180    <MAPF ,LIST
 181          <FUNCTION (A1:ATOM)
 182             <COND (<MEMQ .A1 .L2> <MAPRET .A1>)
 183                   (ELSE <MAPRET>)>>
 184          .L1>>
 185
 186 <DEFINE ATOM-PART (TEMP:<OR ATOM ADECL LIST> "VALUE" ATOM)
 187    <COND (<TYPE? .TEMP ATOM> .TEMP)
 188          (<TYPE? .TEMP ADECL> <1 .TEMP>)
 189          (ELSE <ATOM-PART <1 .TEMP>>)>>
 190
 191 <DEFINE DECL-PART (TEMP:<OR ATOM ADECL LIST>)
 192    <COND (<TYPE? .TEMP ATOM> %<>)
 193          (<TYPE? .TEMP ADECL> <2 .TEMP>)
 194          (ELSE <DECL-PART <1 .TEMP>>)>>
 195
 196 <DEFINE INST-PART (INST)
 197    <COND (<TYPE? .INST BRANCH> <B-INST .INST>)
 198          (<TYPE? .INST LABEL> <L-INST .INST>)
 199          (ELSE .INST)>>
 200
 201 ;"REMOVE-DEADS also counts number of ins (and one extra per ENDIF)"
 202
 203 <DEFINE REMOVE-DEADS (CODE:LIST)
 204    <REPEAT ((RCODE:LIST <REST .CODE>) INST OP (CODE-SIZE:FIX 1))
 205       <COND (<EMPTY? .RCODE> <RETURN .CODE-SIZE>)>
 206       <SET INST <1 .RCODE>>
 207       <COND (<AND <TYPE? .INST FORM>
 208                   <NOT <EMPTY? .INST>>
 209                   <KILL-FUNNY-DEADS .INST>
 210                   <COND (<==? <SET OP <1 .INST>> `DEAD>
 211                          <PUTREST .CODE <SET RCODE <REST .RCODE>>>
 212                          T)
 213                         (<==? .OP `ENDIF>
 214                          <SET CODE-SIZE <+ .CODE-SIZE 1>>
 215                          <>)>>)
 216             (ELSE
 217              <SET CODE-SIZE <+ .CODE-SIZE 1>>
 218              <SET RCODE <REST <SET CODE .RCODE>>>)>>>
 219
 220 <DEFINE KILL-FUNNY-DEADS (INST:FORM "AUX" (N:FIX <LENGTH .INST>) "VALUE" ATOM)
 221         <REPEAT (L FOO)
 222                 <COND (<AND <TYPE? <SET L <NTH .INST .N>> LIST>
 223                             <NOT <EMPTY? .L>>
 224                             <OR <==? <SET FOO <1 .L>> `DEAD-FALL>
 225                                 <==? .FOO `DEAD-JUMP>>>
 226                        <PUTREST <REST .INST <- .N 2>> ()>
 227                        <SET N <- .N 1>>)
 228                       (ELSE <RETURN T>)>>>
 229
 230 <DEFINE PREPARE-LABELS-AND-TEMPS (CODE:VECTOR
 231                                   "AUX"
 232                                   (ALL-VARS:LIST ()) (NTEMPS:FIX 0)
 233                                   (CODELEN:FIX <LENGTH .CODE>)
 234                                   (LOOP-LABELS:<LIST [REST LABEL]> ()))
 235    <REPEAT ((I:FIX 1) INST OP (LOOP-LABEL? %<>) LABEL:LABEL (DID-ENDIF <>))
 236       <SET INST <NTH .CODE .I>>
 237       <COND (<TYPE? .INST ATOM>
 238              <SETG .INST .I>
 239              <SET LABEL <CHTYPE [.INST () 0 %<>] LABEL>>
 240              <COND (.LOOP-LABEL?
 241                     <SET LOOP-LABELS (.LABEL !.LOOP-LABELS)>
 242                     <SET LOOP-LABEL? %<>>)>
 243              <PUT .CODE .I .LABEL>)
 244             (<AND <TYPE? .INST FORM> <NOT <EMPTY? .INST>>>
 245              <SET OP <1 .INST>>
 246              <COND (<OR <==? .OP `END>
 247                         <AND <==? .OP `ENDIF>
 248                              .DID-ENDIF>>
 249                     <SET DID-ENDIF <>>
 250                     <PUT .CODE .I <CHTYPE [.INST () 0 %<>] LABEL>>)
 251                    (<AND <==? .OP `ENDIF> <NOT .DID-ENDIF>>
 252                     <SET DID-ENDIF T>)
 253                    (<==? .OP `LOOP>
 254                     <SET LOOP-LABEL? T>)
 255                    (<==? .OP `ACTIVATION>
 256                     <SET LABEL <CHTYPE [.INST () 0 %<>] LABEL>>
 257                     <SET LOOP-LABELS (.LABEL !.LOOP-LABELS)>
 258                     <PUT .CODE .I .LABEL>)
 259                    (<OR <==? .OP `GFCN>
 260                         <==? .OP `FCN>>
 261                     <SET ALL-VARS (<SET INST <REST .INST 3>> !.ALL-VARS)>
 262                     <SET NTEMPS <+ .NTEMPS <LENGTH .INST>>>)
 263                    (<==? .OP `TEMP>
 264                     <SET ALL-VARS (<SET INST <REST .INST>> !.ALL-VARS)>
 265                     <SET NTEMPS <+ .NTEMPS <LENGTH .INST>>>)
 266                    (<==? .OP `MAKTUP>
 267                     <SET ALL-VARS (<REST .INST> !.ALL-VARS)>
 268                     <SET NTEMPS <+ .NTEMPS <LENGTH .INST> -3>>)>)>
 269       <COND (<==? .I .CODELEN> <RETURN>)>
 270       <SET I <+ .I 1>>>
 271    <CONSTRUCT-TEMPS .NTEMPS .ALL-VARS>
 272    .LOOP-LABELS>
 273
 274 ;"CONSTRUCT-TEMPS SETGs each temp to a uvector.  THe first element ins this temp's
 275   number and the rest are essentially bit masks for the unmeargeabl lists"
 276
 277 <DEFINE CONSTRUCT-TEMPS (NTEMPS:FIX ALL-VARS:<LIST [REST LIST]>
 278                          "AUX" (UVSIZE </32 <+ .NTEMPS 32 31>>)
 279                                (UV-OF-NAMES <IVECTOR .NTEMPS>) (I:FIX 0))
 280         <MAPF <>
 281               <FUNCTION (L:LIST)
 282                    <MAPF <>
 283                          <FUNCTION (ATM "AUX" UV:UVECTOR)
 284                               <COND (<==? .ATM => <MAPLEAVE>)>
 285                               <SETG <SET ATM <ATOM-PART .ATM>>
 286                                     <SET UV <IUVECTOR .UVSIZE 0>>>
 287                               <PUT .UV 1 .I>
 288                               <PUT .UV-OF-NAMES <+ .I 1> .ATM>
 289                               <SET I <+ .I 1>>>
 290                          .L>>
 291               .ALL-VARS>
 292         <SETG NAME-UV .UV-OF-NAMES>
 293         <SETG UVSIZE <- .UVSIZE 1>>             ;"Since only bit masks stored">
 294
 295 <DEFMAC MAKE-BRANCH ('INST)
 296    <FORM CHTYPE [.INST () <FORM IUVECTOR ',UVSIZE 0>
 297                  <FORM IUVECTOR ',UVSIZE 0> %<>] BRANCH>>
 298
 299 ;"END is required to be the location of the return label."
 300
 301 <DEFINE PREPARE-BRANCHES (CODE:VECTOR START:FIX END:FIX RETURN-LABEL:FIX
 302                           ACT-LABELS:<LIST [REST FIX]>)
 303    <REPEAT ((I:FIX .START) INST OP TO ASSIGN LAB:LABEL INST2
 304             (DONT-BRANCH-IFSYS <>))
 305       <SET INST <NTH .CODE .I>>
 306       <COND (<TYPE? .INST LABEL>
 307              <SET INST <L-INST .INST>>
 308              <COND (<AND <TYPE? .INST FORM> <==? <1 .INST> `ACTIVATION>>
 309                     <SET ACT-LABELS (.I .RETURN-LABEL !.ACT-LABELS)>)>
 310              <MAKE-CONNECTION .CODE .I <+ .I 1>>)
 311             (<AND <TYPE? .INST FORM> <NOT <EMPTY? .INST>>>
 312              <SET OP <1 .INST>>
 313              <COND (<==? .OP `ENDIF>
 314                     <COND (<AND <TYPE? <SET INST2 <NTH .CODE <+ .I 2>>> FORM>
 315                                 <NOT <EMPTY? .INST2>>
 316                                 <OR <AND <==? <SET OP <1 .INST2>> `IFSYS>
 317                                          <NOT-MERGEABLE-IFSYS-TYPES <2 .INST2>
 318                                                                     <2 .INST>>>
 319                                     <AND <OR <==? .OP `IFCAN>
 320                                              <==? .OP `IFCANNOT>>
 321                                          <=? <2 .INST> <2 .INST2>>>>>
 322                            ;"ENDIF followed immediately by IFSYS, IFCAN,
 323                              IFCANNOT that is mutually exclusive should act
 324                              like jump to beyond the NEXT ENDIF"
 325                            <SET DONT-BRANCH-IFSYS T>
 326                            <PUT .CODE .I <MAKE-BRANCH .INST>>
 327                            <MAKE-CONNECTION
 328                             .CODE
 329                             .I
 330                             <FUNNY-FIND-ENDIF .CODE
 331                                               <+ .I 1>
 332                                               <2 .INST>
 333                                               <2 .INST2>>>)
 334                           (ELSE
 335                            <MAKE-CONNECTION .CODE .I <+ .I 1>>)>)
 336                    (<==? .OP `JUMP>
 337                     <PUT .CODE .I <MAKE-BRANCH .INST>>
 338                     <SET TO <3 .INST>>
 339                     <COND (<GASSIGNED? .TO>
 340                            <MAKE-CONNECTION .CODE .I ,.TO>)
 341                           (ELSE
 342                            <MAKE-CONNECTION .CODE .I .RETURN-LABEL>)>)
 343                    (<OR <==? .OP `RETURN>
 344                         <==? .OP `MRETURN>
 345                         <==? .OP `RTUPLE>>
 346                     <PUT .CODE .I <MAKE-BRANCH .INST>>
 347                     <MAKE-CONNECTION .CODE .I .RETURN-LABEL>)
 348                    (<==? .OP `SCALL>
 349                     <PUT .CODE .I <MAKE-BRANCH .INST>>
 350                     <COND (<NOT <EMPTY? .ACT-LABELS>>
 351                            <MAPF %<>
 352                                  <FUNCTION (ACT)
 353                                     <MAKE-CONNECTION .CODE .I .ACT>>
 354                                  .ACT-LABELS>)>
 355                     <SET TO <7 .INST>>
 356                     <COND (<AND <GASSIGNED? .TO> <N==? ,.TO <+ .I 1>>>
 357                            <MAKE-CONNECTION .CODE .I ,.TO>)
 358                           (<NOT <GASSIGNED? .TO>>
 359                            <MAKE-CONNECTION .CODE .I .RETURN-LABEL>)>
 360                     <MAKE-CONNECTION .CODE .I <+ .I 1>>)
 361                    (<OR <==? .OP `CALL>
 362                         <==? .OP `ACALL>
 363                         <==? .OP `INTGO>
 364                         <==? .OP `AGAIN>
 365                         <==? .OP `RETRY>
 366                         <==? .OP `CONS>
 367                         <==? .OP `LIST>
 368                         <==? .OP `UBLOCK>
 369                         <==? .OP `UUBLOCK>>
 370                     <COND (<NOT <EMPTY? .ACT-LABELS>>
 371                            <PUT .CODE .I <MAKE-BRANCH .INST>>
 372                            <MAPF %<>
 373                                  <FUNCTION (ACT)
 374                                     <MAKE-CONNECTION .CODE .I .ACT>>
 375                                  .ACT-LABELS>)>
 376                     <MAKE-CONNECTION .CODE .I <+ .I 1>>)
 377                    (<==? .OP `NTHR>
 378                     <SET TO <NTH .INST <LENGTH .INST>>>
 379                     <COND (<AND <TYPE? .TO LIST>
 380                                 <NOT <EMPTY? .TO>>
 381                                 <==? <1 .TO> `BRANCH-FALSE>>
 382                            <SET TO <3 .TO>>
 383                            <PUT .CODE .I <MAKE-BRANCH .INST>>
 384                            <MAKE-CONNECTION .CODE .I <+ .I 1>>
 385                            <COND (<GASSIGNED? .TO>
 386                                   <MAKE-CONNECTION .CODE .I ,.TO>)
 387                                  (ELSE
 388                                   <MAKE-CONNECTION .CODE .I .RETURN-LABEL>)>)>)
 389                    (<==? .OP `DISPATCH>
 390                     <PUT .CODE .I <MAKE-BRANCH .INST>>
 391                     <MAPF %<>
 392                           <FUNCTION (TO)
 393                              <COND (<GASSIGNED? .TO>
 394                                     <MAKE-CONNECTION .CODE .I ,.TO>)
 395                                    (ELSE
 396                                     <MAKE-CONNECTION .CODE .I .RETURN-LABEL>)>>
 397                           <REST .INST 3>>)
 398                    (<OR <==? .OP `IFSYS>
 399                         <==? .OP `IFCAN>
 400                         <==? .OP `IFCANNOT>>
 401                     <COND (<NOT .DONT-BRANCH-IFSYS>
 402                            <PUT .CODE .I <MAKE-BRANCH .INST>>)>
 403                     <MAKE-CONNECTION .CODE .I <+ .I 1>>
 404                     <COND (.DONT-BRANCH-IFSYS <SET DONT-BRANCH-IFSYS <>>)
 405                           (ELSE
 406                            <MAKE-CONNECTION .CODE .I <FIND-ENDIF .CODE .I>>)>)
 407                    (<==? .OP `LOCATION>
 408                     <SET TO ,<3 .INST>>
 409                     <PREPARE-BRANCHES .CODE <+ .I 1> .TO .RETURN-LABEL
 410                                       (.TO !.ACT-LABELS)>
 411                     <SET I .TO>)
 412                    (<==? .OP `ICALL>
 413                     ;"ICALLs are weird."
 414                     <SET TO ,<2 .INST>> ;"the index of the return label"
 415                     ;"If there is an = FOO in the ICALL, this is actually
 416                       set at the return label, so make that happen."
 417                     <SET ASSIGN <MEMQ = <REST .INST 2>>>
 418                     <COND (.ASSIGN
 419                            <SET LAB <NTH .CODE .TO>>
 420                            <L-ASSIGN .LAB ((<2 .ASSIGN> .I)
 421                                            !<L-ASSIGN .LAB>)>)>
 422                     <PREPARE-BRANCHES .CODE <+ .I 1> .TO .TO .ACT-LABELS>
 423                     <SET I .TO>)
 424                    (<OR <SET TO <MEMQ + .INST>>
 425                         <SET TO <MEMQ - .INST>>>
 426                     <SET TO <2 .TO>>
 427                     <PUT .CODE .I <MAKE-BRANCH .INST>>
 428                     <MAKE-CONNECTION .CODE .I <+ .I 1>>
 429                     <COND (<GASSIGNED? .TO>
 430                            <MAKE-CONNECTION .CODE .I ,.TO>)
 431                           (ELSE
 432                            <MAKE-CONNECTION .CODE .I .RETURN-LABEL>)>)
 433                    (ELSE
 434                     <MAKE-CONNECTION .CODE .I <+ .I 1>>)>)>
 435       <SET I <+ .I 1>>
 436       <COND (<==? .I .END> <RETURN .CODE>)>>
 437    .CODE>
 438
 439 <DEFINE MAKE-CONNECTION (CODE:VECTOR FROM:FIX TO:FIX
 440                          "AUX" FROM-BRANCH TO-LABEL)
 441    <COND (<TYPE? <SET FROM-BRANCH <NTH .CODE .FROM>> BRANCH>
 442           <B-OUTS .FROM-BRANCH (.TO !<B-OUTS .FROM-BRANCH>)>)>
 443    <COND (<TYPE? <SET TO-LABEL <NTH .CODE .TO>> LABEL>
 444           <L-INS .TO-LABEL (.FROM !<L-INS .TO-LABEL>)>)>
 445    T>
 446
 447 ;"NOT-MERGEABLE-IFSYS-TYPES returns true if the ifsys args aren't a subset"
 448
 449 <DEFINE NOT-MERGEABLE-IFSYS-TYPES (A B)
 450         <COND (<=? .A "TOPS20"> <N=? .B "TOPS20">)
 451               (<=? .B "TOPS20"> T)
 452               (<=? .A "UNIX"> <> ;"B must be VAX, MAC or UNIX")
 453               (<=? .B "UNIX"> <> ;"A must be VAX, MAC or UNIX")
 454               (<N=? .A .B> T)>>
 455
 456 <DEFINE FIND-ENDIF (CODE:VECTOR I:FIX)
 457         <REAL-FIND-ENDIF .CODE .I <>>>
 458
 459 <DEFINE FUNNY-FIND-ENDIF (CODE:VECTOR I:FIX "TUPLE" MTUP)
 460         <REAL-FIND-ENDIF .CODE .I .MTUP>>
 461
 462 <DEFINE REAL-FIND-ENDIF (CODE:VECTOR I:FIX MTUP:<OR FALSE <PRIMTYPE VECTOR>>
 463                          "AUX" (LEVEL:FIX 0))
 464    <REPEAT (INST OP)
 465       <SET I <+ .I 1>>
 466       <SET INST <NTH .CODE .I>>
 467       <COND (<AND <TYPE? .INST LABEL>
 468                   <TYPE? <SET INST <L-INST .INST>> FORM>
 469                   <NOT <EMPTY? .INST>>>
 470              <SET OP <1 .INST>>
 471              <COND (<==? .OP `ENDIF>
 472                     <COND
 473                      (<0? .LEVEL>
 474                       <COND
 475                        (<AND .MTUP
 476                              <TYPE? <SET INST <NTH .CODE <+ .I 2>>>
 477                                     FORM>
 478                              <==? <1 .INST> `IFSYS>
 479                              <MAPF <>
 480                                    <FUNCTION (S)
 481                                         <COND (<NOT-MERGEABLE-IFSYS-TYPES
 482                                                 .S <2 .INST>>
 483                                                T)
 484                                               (ELSE <MAPLEAVE <>>)>>
 485                                    .MTUP>>
 486                         <SET I <+ .I 1>>)
 487                        (ELSE <RETURN .I>)>)
 488                      (ELSE <SET LEVEL <- .LEVEL 1>>)>)
 489                    (<OR <==? .OP `IFSYS>
 490                         <==? .OP `IFCAN>
 491                         <==? .OP `IFCANNOT>>
 492                     <SET LEVEL <+ .LEVEL 1>>)>)>>>
 493
 494 <DEFINE BACKWALK-FROM-LABEL (CODE:VECTOR LABEL:LABEL CUR-LEV:FIX)
 495    <MAPF %<>
 496          <FUNCTION (IN:FIX "AUX" (INST <NTH .CODE .IN>))
 497             <COND (<TYPE? .INST BRANCH>
 498                    <BACKWALK .CODE .IN <UVECTOR !<B-LIVES .INST>> .CUR-LEV>)>>
 499          <L-INS .LABEL>>>
 500
 501 <DEFINE BACKWALK (CODE:VECTOR I:FIX LIVE-TEMPS:UVECTOR CUR-LEV:FIX)
 502    <REPEAT (INST INS:<LIST [REST FIX]>
 503             ASSIGN:<OR FALSE <LIST [REST !<LIST ATOM FIX>]>>)
 504       <SET INST <NTH .CODE .I>>
 505       <COND (<TYPE? .INST LABEL>
 506              <COND (<L=? .CUR-LEV <L-LEVEL .INST>> <RETURN>)
 507                    (ELSE <L-LEVEL .INST .CUR-LEV>)>
 508              <SET ASSIGN <L-ASSIGN .INST>>
 509              <SET INS <L-INS .INST>>
 510              <COND (<EMPTY? .INS>
 511                     <COND (<==? .CUR-LEV 1>
 512                            <PRINTSTRING
 513                             "FILE-DEATH: Warning--unreachable code at "
 514                             .OUTCHAN>
 515                            <PRIN1 <L-INST .INST> .OUTCHAN>
 516                            <CRLF .OUTCHAN>
 517                            <RETURN>)>)
 518                    (ELSE
 519                     <MAPF %<>
 520                           <FUNCTION (IN "AUX" (LV:UVECTOR <UVECTOR !.LIVE-TEMPS>))
 521                              <COND (.ASSIGN
 522                                     <MAPF <>
 523                                           <FUNCTION (LL:!<LIST ATOM FIX>)
 524                                                <COND (<==? <2 .LL> .IN>
 525                                                       <REM-LIST <1 .LL> .LV>
 526                                                       <UNMERGEABLE <1 .LL> .LV>
 527                                                       <MAPLEAVE>)>>
 528                                           .ASSIGN>)>
 529                              <BACKWALK .CODE .IN .LV .CUR-LEV>>
 530                           <REST .INS>>
 531                     <SET I <1 .INS>>
 532                     <COND (.ASSIGN
 533                            <MAPF <>
 534                                  <FUNCTION (LL:!<LIST ATOM FIX>)
 535                                       <COND (<==? <2 .LL> .I>
 536                                              <REM-LIST <1 .LL> .LIVE-TEMPS>
 537                                              <UNMERGEABLE <1 .LL> .LIVE-TEMPS>
 538                                              <MAPLEAVE>)>>
 539                                  .ASSIGN>)>)>)
 540             (<TYPE? .INST BRANCH>
 541              <SET LIVE-TEMPS <MERGE-TEMPS .LIVE-TEMPS .INST>>
 542              <SET LIVE-TEMPS <UPDATE-TEMPS <B-INST .INST> .LIVE-TEMPS>>
 543              <SET I <- .I 1>>)
 544             (ELSE       ;"had better be a form"
 545              <SET LIVE-TEMPS <UPDATE-TEMPS .INST .LIVE-TEMPS>>
 546              <SET I <- .I 1>>)>
 547       <COND (<0? .I> <RETURN>)>>>
 548
 549 <DEFINE MERGE-TEMPS (LIVES:UVECTOR BRANCH:BRANCH
 550                      "AUX" B-LIVES:UVECTOR (TEMP-OFFS:FIX 0))
 551    ;"Add to each list the items on the other list."
 552    ;"Every time a temp is added to B-LIVES, it must be declared UNMERGEABLE
 553      with the ones already there."
 554    <SET B-LIVES <B-LIVES .BRANCH>>
 555    ;"First put all temps from both into LIVES"
 556    <MAPR <>
 557          <FUNCTION (LP:UVECTOR BP:UVECTOR)
 558               <PUT .LP 1 <ORB <1 .LP> <1 .BP>>>>
 559          .LIVES .B-LIVES>
 560    ;"Now make any to be added to B-LIVES unmeargable with those there and
 561      flag the fact that a change occured"
 562    <MAPR <>
 563          <FUNCTION (LP:UVECTOR BP:UVECTOR
 564                     "AUX" (ADDED:FIX <XORB <1 .LP> <1 .BP>>))
 565               <COND (<N==? .ADDED 0>
 566                      ;"Something was added to B-LIVES"
 567                      <SETG SOMETHING-CHANGED T>
 568                      ;"Now do the unmergeables"
 569                      <REPEAT ((TNO:FIX <+ .TEMP-OFFS 1>) (MSK:FIX 1))
 570                              <COND (<N==? <ANDB .MSK .ADDED> 0>
 571                                     <SET ADDED <XORB .ADDED .MSK>>
 572                                     <UNMERGEABLE <NTH ,NAME-UV .TNO> .LIVES>
 573                                     <COND (<==? .ADDED 0> <RETURN>)>)>
 574                              <SET MSK <LSH .MSK 1>>
 575                              <SET TNO <+ .TNO 1>>>)>
 576               <SET TEMP-OFFS <+ .TEMP-OFFS 32>>
 577               <PUT .BP 1 <1 .LP>>>
 578          .LIVES .B-LIVES>
 579    <B-LIVES .BRANCH .B-LIVES>
 580    .LIVES>
 581
 582 ;"ICALL is weird.  Even though it can have an = FOO, this assignment
 583   effectively takes place at the exit label."
 584
 585 <DEFINE UPDATE-TEMPS (INST:FORM LIVES:UVECTOR
 586                       "AUX" OP ITEM TWO THREE FOUR)
 587    <COND (<NOT <EMPTY? .INST>>
 588           <SET OP <1 .INST>>
 589           <COND (<==? .OP `SET>
 590                  <REM-LIST <SET TWO <2 .INST>> .LIVES>
 591                  <UNMERGEABLE .TWO .LIVES>
 592                  <COND (<TYPE? <SET THREE <3 .INST>> ATOM>
 593                         <SET LIVES <ADD-LIVE .THREE .LIVES>>)>)
 594                 (<==? .OP `SETLR>
 595                  <REM-LIST <SET TWO <2 .INST>> .LIVES>
 596                  <UNMERGEABLE .TWO .LIVES>
 597                  <COND (<TYPE? <SET THREE <3 .INST>> ATOM>
 598                         <SET LIVES <ADD-LIVE .THREE .LIVES>>)>
 599                  <COND (<TYPE? <SET FOUR <4 .INST>> ATOM>
 600                         <SET LIVES <ADD-LIVE .FOUR .LIVES>>)>)
 601                 (<==? .OP `SETRL>
 602                  <REM-LIST <SET THREE <3 .INST>> .LIVES>
 603                  <UNMERGEABLE .THREE .LIVES>
 604                  <COND (<TYPE? <SET TWO <2 .INST>> ATOM>
 605                         <SET LIVES <ADD-LIVE .TWO .LIVES>>)>
 606                  <COND (<TYPE? <SET FOUR <4 .INST>> ATOM>
 607                         <SET LIVES <ADD-LIVE .FOUR .LIVES>>)>)
 608                 (<==? .OP `TEMP>
 609                  <MAPF %<>
 610                        <FUNCTION (T "AUX" ATM)
 611                           <COND (<TYPE? .T LIST>
 612                                  <REM-LIST <SET ATM <ATOM-PART .T>>
 613                                            .LIVES>
 614                                  <UNMERGEABLE .ATM .LIVES>)>>
 615                        <REST .INST>>)
 616                 (<==? .OP `MAKTUP>
 617                  <MAPF %<>
 618                        <FUNCTION (T "AUX" ATM)
 619                           <COND (<==? .T => <MAPLEAVE>)
 620                                 (<TYPE? .T LIST>
 621                                  <REM-LIST <SET ATM <ATOM-PART .T>>
 622                                            .LIVES>
 623                                  <UNMERGEABLE .ATM .LIVES>)>>
 624                        <REST .INST>>)
 625                 (<==? .OP `DISPATCH>
 626                  <COND (<TYPE? <SET TWO <2 .INST>> ATOM>
 627                         <SET LIVES <ADD-LIVE .TWO .LIVES>>)>
 628                  <COND (<TYPE? <SET THREE <3 .INST>> ATOM>
 629                         <SET LIVES <ADD-LIVE .THREE .LIVES>>)>)
 630                 (<AND <N==? .OP `FCN>
 631                       <N==? .OP `GFCN>
 632                       <N==? .OP `LOOP>
 633                       <N==? .OP `END>
 634                       <N==? .OP `ICALL>
 635                       <N==? .OP `OPT-DISPATCH>>
 636                  <SET ITEM <MEMQ = <REST .INST>>>
 637                  <COND (.ITEM
 638                         <COND (<N==? <SET TWO <2 .ITEM>> `STACK>
 639                                <REM-LIST .TWO .LIVES>
 640                                <UNMERGEABLE .TWO .LIVES>)>)>
 641                  <REPEAT ((RINST <REST .INST>) ONE)
 642                     <COND (<EMPTY? .RINST> <RETURN>)>
 643                     <SET ONE <1 .RINST>>
 644                     <COND (<OR <==? .ONE =>
 645                                <==? .ONE +>
 646                                <==? .ONE ->>
 647                            <SET RINST <REST .RINST 2>>)
 648                           (<TYPE? .ONE ATOM>
 649                            <SET LIVES <ADD-LIVE .ONE .LIVES>>
 650                            <SET RINST <REST .RINST>>)
 651                           (<AND <==? .OP `CHTYPE>
 652                                 <TYPE? .ONE FORM>
 653                                 <NOT <LENGTH? .ONE 1>>
 654                                 <==? <1 .ONE> `TYPE>
 655                                 <TYPE? <SET TWO <2 .ONE>> ATOM>>
 656                            <SET LIVES <ADD-LIVE .TWO .LIVES>>
 657                            <SET RINST <REST .RINST>>)
 658                           (ELSE
 659                            <SET RINST <REST .RINST>>)>>)>)>
 660    .LIVES>
 661
 662 <DEFINE ADD-LIVE (ATM:ATOM L:UVECTOR
 663                   "AUX" NL:<OR FALSE UVECTOR>
 664                   "VALUE" UVECTOR)
 665    <SET NL <ADD-LIST? .ATM .L>>
 666    <COND (.NL <UNMERGEABLE .ATM .L> .NL)
 667          (ELSE .L)>>
 668
 669 <DEFINE UNMERGEABLE (NEW-LIVE:ATOM LIVES:UVECTOR
 670                     "AUX" NL-LIST:UVECTOR NUM:FIX WD:FIX BIT:FIX
 671                           (TEMP-OFFS:FIX 0))
 672    ;"The error tests were removed to make things run faster.  Believe it
 673      or not, this function is one of the big time sinks of the package."
 674    <COND (<NOT <GASSIGNED? .NEW-LIVE>>
 675           <ERROR TEMP-WITHOUT-LIST!-ERRORS .NEW-LIVE UNMERGEABLE>)>
 676    <COND (<N==? .NEW-LIVE `STACK>
 677           <SET NL-LIST ,.NEW-LIVE>
 678           <SET NUM <1 .NL-LIST>>
 679           <SET NL-LIST <REST .NL-LIST>>
 680           <MAPF <>
 681                 <FUNCTION (LIVE:FIX "AUX" ATM)
 682                      <COND (<N==? .LIVE 0>
 683                             <REPEAT ((TNO:FIX .TEMP-OFFS) (MSK:FIX 1))
 684                                     <COND (<AND <N==? <ANDB .LIVE .MSK> 0>
 685                                                 <SET LIVE <XORB .LIVE .MSK>>
 686                                                 <COND (<N==? .TNO .NUM>)
 687                                                       (<==? .LIVE 0>
 688                                                        <RETURN>)>>
 689                                            <SET ATM <NTH ,NAME-UV
 690                                                          <+ .TNO 1>>>
 691                                            <COND (<NOT <GASSIGNED? .ATM>>
 692                                                   <ERROR
 693                                                    TEMP-WITHOUT-LIST!-ERRORS
 694                                                    .ATM UNMERGEABLE>)>
 695                                            <ADD-LIST .ATM .NL-LIST>
 696                                            <ADD-LIST .NEW-LIVE <REST ,.ATM>>
 697                                            <COND (<==? .LIVE 0> <RETURN>)>)>
 698                                     <SET TNO <+ .TNO 1>>
 699                                     <SET MSK <LSH .MSK 1>>>)>
 700                      <SET TEMP-OFFS <+ .TEMP-OFFS 32>>>
 701                 .LIVES>)>
 702    T>
 703
 704 <DEFINE OPTIMIZE-SETS (CODE:VECTOR)
 705    <REPEAT ((I:FIX 1) (CODELEN:FIX <LENGTH .CODE>) INST ATM1 ATM2)
 706       <SET INST <NTH .CODE .I>>
 707       <COND (<AND <TYPE? .INST FORM>
 708                   <NOT <LENGTH? .INST 2>>
 709                   <==? <1 .INST> `SET>
 710                   <TYPE? <SET ATM1 <2 .INST>> ATOM>
 711                   <TYPE? <SET ATM2 <3 .INST>> ATOM>
 712                   <NOT <IN-LIST? .ATM1 <REST ,.ATM2>>>>
 713              <MAYBE-MERGE .CODE .ATM1 .ATM2>)>
 714       <COND (<==? .I .CODELEN> <RETURN>)>
 715       <SET I <+ .I 1>>>>
 716
 717 <DEFINE MAYBE-MERGE (CODE:VECTOR ATM1:ATOM ATM2:ATOM)
 718    <REPEAT WHOLE-THING ((I:FIX 1) (CODELEN:FIX <LENGTH .CODE>) INST)
 719       <SET INST <NTH .CODE .I>>
 720       <COND (<AND <TYPE? .INST FORM>
 721                   <NOT <EMPTY? .INST>>
 722                   <OR <==? <1 .INST> `TEMP>
 723                       <==? <1 .INST> `MAKTUP>>>
 724              <REPEAT ((LONG:LIST <REST .INST>) ONE-LONG)
 725                 <COND (<OR <EMPTY? .LONG>
 726                            <==? <SET ONE-LONG <1 .LONG>> =>>
 727                        <RETURN>)
 728                       (<==? <ATOM-PART .ONE-LONG> .ATM1>
 729                        <PROBABLY-MERGE .CODE .LONG .ATM1 .ATM2>
 730                        <RETURN T .WHOLE-THING>)
 731                       (<==? <ATOM-PART .ONE-LONG> .ATM2>
 732                        <PROBABLY-MERGE .CODE .LONG .ATM2 .ATM1>
 733                        <RETURN T .WHOLE-THING>)>
 734                 <SET LONG <REST .LONG>>>)>
 735       <COND (<==? .I .CODELEN> <RETURN>)>
 736       <SET I <+ .I 1>>>
 737    T>
 738
 739 <DEFINE PROBABLY-MERGE (CODE:VECTOR LONG:LIST NEW-TEMP:ATOM OLD-TEMP:ATOM
 740                         "AUX" (OUTCHAN:CHANNEL .OUTCHAN))
 741    <REPEAT ((MEDIUM:LIST .LONG) (SHORT:LIST <REST .LONG>) ONE-SHORT)
 742       <COND (<OR <EMPTY? .SHORT> <==? <SET ONE-SHORT <1 .SHORT>> =>> <RETURN>)
 743             (<==? <ATOM-PART .ONE-SHORT> .OLD-TEMP>
 744              <COND (<MERGEABLE? <1 .LONG> .ONE-SHORT>
 745                     <COND (<TYPE? .ONE-SHORT LIST>
 746                            <1 .LONG <1 .ONE-SHORT <1 .LONG>>>)>
 747                     <PUTREST .MEDIUM <REST .SHORT>>
 748                     <COND (,DEBUG-DEATH
 749                            <PRINTSTRING "Merging " .OUTCHAN>
 750                            <PRIN1 .OLD-TEMP .OUTCHAN>
 751                            <PRINTSTRING " with " .OUTCHAN>
 752                            <PRIN1 .NEW-TEMP .OUTCHAN>
 753                            <CRLF .OUTCHAN>)>
 754                     <UNMERGEABLE .NEW-TEMP <REST ,.OLD-TEMP>>
 755                     <PERFORM-MERGE .CODE .NEW-TEMP .OLD-TEMP>)>
 756              <RETURN>)>
 757       <SET SHORT <REST <SET MEDIUM .SHORT>>>>
 758    T>
 759
 760 <DEFINE OPTIMIZE-TEMPS (CODE:VECTOR)
 761    <REPEAT ((I:FIX 1) (CODELEN:FIX <LENGTH .CODE>) INST OP)
 762       <SET INST <NTH .CODE .I>>
 763       <COND (<AND <TYPE? .INST FORM>
 764                   <NOT <EMPTY? .INST>>>
 765              <SET OP <1 .INST>>
 766              <COND (<OR <==? .OP `TEMP> <==? .OP `MAKTUP>>
 767                     <REALLY-OPTIMIZE .CODE <REST .INST>>)>)>
 768       <COND (<==? .I .CODELEN> <RETURN>)>
 769       <SET I <+ .I 1>>>>
 770
 771 <DEFINE REALLY-OPTIMIZE (CODE:VECTOR TEMPS:LIST
 772                          "AUX" (OUTCHAN:CHANNEL .OUTCHAN)
 773                          OLD-TEMP:ATOM NEW-TEMP:ATOM)
 774    <COND (<NOT <EMPTY? .TEMPS>>
 775           <REPEAT ((LONG:LIST .TEMPS) ONE-LONG)
 776              <COND (<OR <EMPTY? .LONG> <==? <SET ONE-LONG <1 .LONG>> =>> <RETURN>)>
 777              <REPEAT ((MEDIUM:LIST .LONG) (SHORT:LIST <REST .MEDIUM>) ONE-SHORT)
 778                 <COND (<OR <EMPTY? .SHORT> <==? <SET ONE-SHORT <1 .SHORT>> =>>
 779                        <RETURN>)>
 780                 <COND (<MERGEABLE? .ONE-LONG .ONE-SHORT>
 781                        <SET NEW-TEMP <ATOM-PART .ONE-LONG>>
 782                        <SET OLD-TEMP <ATOM-PART .ONE-SHORT>>
 783                        <COND (<TYPE? .ONE-SHORT LIST>
 784                               <1 .LONG <1 .ONE-SHORT .ONE-LONG>>)>
 785                        <PUTREST .MEDIUM <SET SHORT <REST .SHORT>>>
 786                        <COND (,DEBUG-DEATH
 787                               <PRINTSTRING "Merging " .OUTCHAN>
 788                               <PRIN1 .OLD-TEMP .OUTCHAN>
 789                               <PRINTSTRING " with " .OUTCHAN>
 790                               <PRIN1 .NEW-TEMP .OUTCHAN>
 791                               <CRLF .OUTCHAN>)>
 792                        <UNMERGEABLE .NEW-TEMP <REST ,.OLD-TEMP>>
 793                        <PERFORM-MERGE .CODE .NEW-TEMP .OLD-TEMP>)
 794                       (ELSE
 795                        <SET SHORT <REST <SET MEDIUM .SHORT>>>)>>
 796              <SET LONG <REST .LONG>>>)>>
 797
 798 <DEFINE MERGEABLE? (TEMP1:<OR ATOM ADECL LIST> TEMP2:<OR ATOM ADECL LIST>)
 799    <AND <==? <DECL-PART .TEMP1> <DECL-PART .TEMP2>>
 800         <NOT <AND <TYPE? .TEMP1 LIST> <TYPE? .TEMP2 LIST>>>
 801         <NOT <IN-LIST? <ATOM-PART .TEMP1> <REST ,<ATOM-PART .TEMP2>>>>>>
 802
 803 <DEFINE OPTIMIZE-TEMPS/BASH-DECLS (CODE:VECTOR)
 804    <REPEAT ((I:FIX 1) (CODELEN:FIX <LENGTH .CODE>) INST OP)
 805       <SET INST <NTH .CODE .I>>
 806       <COND (<AND <TYPE? .INST FORM>
 807                   <NOT <EMPTY? .INST>>>
 808              <SET OP <1 .INST>>
 809              <COND (<OR <==? .OP `TEMP> <==? .OP `MAKTUP>>
 810                     <REALLY-OPTIMIZE/BASH-DECLS .CODE <REST .INST>>)>)>
 811       <COND (<==? .I .CODELEN> <RETURN>)>
 812       <SET I <+ .I 1>>>>
 813
 814 <DEFINE REALLY-OPTIMIZE/BASH-DECLS (CODE:VECTOR TEMPS:LIST
 815                                     "AUX" (OUTCHAN:CHANNEL .OUTCHAN)
 816                                     OLD-TEMP:ATOM NEW-TEMP:ATOM)
 817    <COND (<NOT <EMPTY? .TEMPS>>
 818           <REPEAT ((LONG:LIST .TEMPS) ONE-LONG)
 819              <COND (<OR <EMPTY? .LONG> <==? <SET ONE-LONG <1 .LONG>> =>>
 820                     <RETURN>)>
 821              <REPEAT ((MEDIUM:LIST .LONG) (SHORT:LIST <REST .MEDIUM>) ONE-SHORT)
 822                 <COND (<OR <EMPTY? .SHORT> <==? <SET ONE-SHORT <1 .SHORT>> =>>
 823                        <RETURN>)>
 824                 <COND (<MERGEABLE?/BASH-DECLS .ONE-LONG .ONE-SHORT>
 825                        <SET NEW-TEMP <ATOM-PART .ONE-LONG>>
 826                        <SET OLD-TEMP <ATOM-PART .ONE-SHORT>>
 827                        <COND (<AND <DECL-PART .ONE-LONG>
 828                                    <N==? <DECL-PART .ONE-LONG>
 829                                          <DECL-PART .ONE-SHORT>>>
 830                               <COND (<TYPE? .ONE-LONG ADECL>
 831                                      <1 .LONG <SET ONE-LONG <1 .ONE-LONG>>>)
 832                                     (<TYPE? .ONE-LONG LIST>
 833                                      <1 .ONE-LONG <1 <1 .ONE-LONG>>>)>)>
 834                        <COND (<TYPE? .ONE-SHORT LIST>
 835                               <1 .LONG <1 .ONE-SHORT .ONE-LONG>>)>
 836                        <PUTREST .MEDIUM <SET SHORT <REST .SHORT>>>
 837                        <COND (,DEBUG-DEATH
 838                               <PRINTSTRING "Merging " .OUTCHAN>
 839                               <PRIN1 .OLD-TEMP .OUTCHAN>
 840                               <PRINTSTRING " with " .OUTCHAN>
 841                               <PRIN1 .NEW-TEMP .OUTCHAN>
 842                               <CRLF .OUTCHAN>)>
 843                        <UNMERGEABLE .NEW-TEMP <REST ,.OLD-TEMP>>
 844                        <PERFORM-MERGE .CODE .NEW-TEMP .OLD-TEMP>)
 845                       (ELSE
 846                        <SET SHORT <REST <SET MEDIUM .SHORT>>>)>>
 847              <SET LONG <REST .LONG>>>)>>
 848
 849 <DEFINE MERGEABLE?/BASH-DECLS (TEMP1:<OR ATOM ADECL LIST>
 850                                TEMP2:<OR ATOM ADECL LIST>)
 851    <AND <NOT <AND <TYPE? .TEMP1 LIST> <TYPE? .TEMP2 LIST>>>
 852         <NOT <IN-LIST? <ATOM-PART .TEMP1> <REST ,<ATOM-PART .TEMP2>>>>>>
 853
 854 <DEFINE PERFORM-MERGE (CODE:VECTOR NEW-TEMP:ATOM OLD-TEMP:ATOM)
 855    <MAPF %<>
 856          <FUNCTION (INST "AUX" OP L ASSIGN)
 857             <COND (<TYPE? .INST BRANCH>
 858                    <COND (<IN-LIST? .OLD-TEMP <B-LIVES .INST>>
 859                           <REM-LIST .OLD-TEMP <B-LIVES .INST>>
 860                           <ADD-LIST .NEW-TEMP <B-LIVES .INST>>)>
 861                    <SET INST <B-INST .INST>>)
 862                   (<TYPE? .INST LABEL>
 863                    <COND (<SET ASSIGN <L-ASSIGN .INST>>
 864                           <MAPF <>
 865                                 <FUNCTION (LL:!<LIST ATOM FIX>)
 866                                      <COND (<==? <1 .LL> .OLD-TEMP>
 867                                             <PUT .LL 1 .NEW-TEMP>
 868                                             <MAPLEAVE>)>>
 869                                 .ASSIGN>)>
 870                    <SET INST <L-INST .INST>>)>
 871             <COND (<AND <TYPE? .INST FORM> <NOT <EMPTY? .INST>>>
 872                    <SET OP <1 .INST>>
 873                    <COND (<==? .OP `LOOP>
 874                           <MAPF %<>
 875                                 <FUNCTION (L)
 876                                    <REPLACE-ATOM .L .NEW-TEMP .OLD-TEMP>>
 877                                 <REST .INST>>)
 878                          (<==? .OP `ICALL>
 879                           <COND (<G=? <LENGTH .INST> 3>
 880                                  <REPLACE-ATOM <REST .INST 3>
 881                                                .NEW-TEMP
 882                                                .OLD-TEMP>)>)
 883                          (<==? .OP `CHTYPE>
 884                           <REPLACE-ATOM <REST .INST> .NEW-TEMP .OLD-TEMP>
 885                           <MAPF %<>
 886                                 <FUNCTION (I)
 887                                    <COND (<AND <TYPE? .I FORM>
 888                                                <NOT <LENGTH? .I 1>>
 889                                                <==? <1 .I> `TYPE>
 890                                                <==? <2 .I> .OLD-TEMP>>
 891                                           <2 .I .NEW-TEMP>)>>
 892                                 <REST .INST>>)
 893                          (ELSE
 894                           <REPLACE-ATOM <REST .INST> .NEW-TEMP .OLD-TEMP>)>)>>
 895          .CODE>>
 896
 897 <DEFINE REPLACE-ATOM (L:<PRIMTYPE LIST> NEW-ATOM:ATOM OLD-ATOM:ATOM)
 898    <MAPR %<>
 899          <FUNCTION (RL "AUX" (ONE <1 .RL>))
 900             <COND (<==? .ONE .OLD-ATOM>
 901                    <1 .RL .NEW-ATOM>)>>
 902          .L>
 903    T>
 904
 905 <DEFINE PREPARE-DEADS-FROM-LABEL (CODE:VECTOR LABEL:LABEL)
 906    <MAPF %<>
 907          <FUNCTION (IN:FIX "AUX" (INST <NTH .CODE .IN>))
 908             <COND (<TYPE? .INST BRANCH>
 909                    <PREPARE-DEADS .CODE .IN <UVECTOR !<B-LIVES .INST>> -1>)>>
 910          <L-INS .LABEL>>>
 911
 912 <DEFINE PREPARE-DEADS (CODE:VECTOR I:FIX LIVE-TEMPS:UVECTOR
 913                        FROM:FIX)
 914    <REPEAT (INST INS:<LIST [REST FIX]>
 915             ASSIGN:<OR FALSE <LIST [REST !<LIST ATOM FIX>]>>)
 916       <SET INST <NTH .CODE .I>>
 917       <COND (<TYPE? .INST LABEL>
 918              <COND (<==? <L-LEVEL .INST> -1> <RETURN>)
 919                    (ELSE <L-LEVEL .INST -1>)>
 920              <SET ASSIGN <L-ASSIGN .INST>>
 921              <SET INS <L-INS .INST>>
 922              <COND (<EMPTY? .INS>
 923                     <ERROR UNREACHABLE-CODE!-ERRORS PREPARE-DEADS>)
 924                    (ELSE
 925                     <MAPF %<>
 926                           <FUNCTION (IN "AUX" (LV:UVECTOR <UVECTOR !.LIVE-TEMPS>))
 927                              <COND (.ASSIGN
 928                                     <MAPF <>
 929                                           <FUNCTION (LL:!<LIST ATOM FIX>)
 930                                                <COND (<==? <2 .LL> .IN>
 931                                                       <REM-LIST <1 .LL> .LV>
 932                                                       <MAPLEAVE>)>>
 933                                           .ASSIGN>)>
 934                              <PREPARE-DEADS .CODE .IN .LV .I>>
 935                           <REST .INS>>
 936                     <SET FROM .I>
 937                     <SET I <1 .INS>>
 938                     <COND (.ASSIGN
 939                            <MAPF <>
 940                                  <FUNCTION (LL:!<LIST ATOM FIX>)
 941                                       <COND (<==? <2 .LL> .I>
 942                                              <REM-LIST <1 .LL> .LIVE-TEMPS>
 943                                              <MAPLEAVE>)>>
 944                                  .ASSIGN>)>)>)
 945             (<TYPE? .INST BRANCH>
 946              <SET LIVE-TEMPS
 947                   <MERGE-DEADS .LIVE-TEMPS .INST <==? .FROM <+ .I 1>>>>
 948              <SET LIVE-TEMPS <UPDATE-DEADS <B-INST .INST> .LIVE-TEMPS>>
 949              <SET FROM .I>
 950              <SET I <- .I 1>>)
 951             (ELSE       ;"had better be a form"
 952              <SET LIVE-TEMPS <UPDATE-DEADS .INST .LIVE-TEMPS>>
 953              <SET FROM .I>
 954              <SET I <- .I 1>>)>
 955       <COND (<0? .I> <RETURN>)>>>
 956
 957 <DEFINE MERGE-DEADS (LIVES:UVECTOR BRANCH:BRANCH FALL?
 958                      "AUX" B-LIVES:UVECTOR
 959                      (ND1:UVECTOR <IUVECTOR ,UVSIZE 0>) JD)
 960    ;"Add to LIVES any atoms that are not already there.  Do this without
 961      modifying B-LIVES.  Declare all atoms added DEAD in the appropriate
 962      place."
 963    ;"Since we know that LIVES is a subset of B-LIVES, much of the code
 964      goes away."
 965    <SET B-LIVES <B-LIVES .BRANCH>>
 966    <MAPR <>
 967          <FUNCTION (LP:UVECTOR BP:UVECTOR NDP:UVECTOR "AUX" L:FIX B:FIX)
 968               <COND (<N==? <SET L <1 .LP>> <SET B <1 .BP>>>
 969                      <PUT .LP 1 <ORB .L .B>>
 970                      <PUT .NDP 1 <XORB .L .B>>)>>
 971          .LIVES .B-LIVES .ND1>
 972    <COND (.FALL?
 973           <B-FALL-DEADS .BRANCH .ND1>)
 974          (ELSE
 975           <SET JD <B-JUMP-DEADS .BRANCH>>
 976           <COND (.JD
 977                  <B-JUMP-DEADS .BRANCH <INTERSECT-UVS .ND1 .JD>>)
 978                 (ELSE
 979                  <B-JUMP-DEADS .BRANCH .ND1>)>)>
 980    .LIVES>
 981
 982 <DEFINE INTERSECT-UVS (U1:UVECTOR U2:UVECTOR "AUX" (U3:UVECTOR <IUVECTOR ,UVSIZE>))
 983         <MAPR <>
 984               <FUNCTION (UP1 UP2 UP3)
 985                    <PUT .UP3 1 <ANDB <1 .UP1> <1 .UP2>>>>
 986               .U1 .U2 .U3>
 987         .U3>
 988
 989
 990
 991 ;"ICALL is weird.  Even though it can have an = FOO, this assignment
 992   effectively takes place at the exit label."
 993
 994 <DEFINE UPDATE-DEADS (INST:FORM LIVES:UVECTOR "AUX" SETTER OP TEM)
 995    ;"Any time an atom is added to the list of LIVES, it must be declared
 996      DEAD, unless it is also SET in the same instruction."
 997    <COND (<NOT <EMPTY? .INST>>
 998           <SET OP <1 .INST>>
 999           <COND (<==? .OP `SET>
1000                  <SET SETTER <CHTYPE <2 .INST> ATOM>>
1001                  <COND (<NOT <REM-LIST? .SETTER .LIVES>>
1002                         <SETG ANY-FLUSHED-INS T>
1003                         <PUT .INST 2 <CHTYPE .SETTER DEAD-VAR>>)>
1004                  <COND (<TYPE? <3 .INST> ATOM DEAD-VAR>
1005                         <ADD-DEAD <REST .INST 2> .LIVES .SETTER>)>)
1006                 (<==? .OP `SETLR>
1007                  <SET SETTER <CHTYPE <2 .INST> ATOM>>
1008                  <COND (<NOT <REM-LIST? .SETTER .LIVES>>
1009                         <SETG ANY-FLUSHED-INS T>
1010                         <PUT .INST 2 <CHTYPE .SETTER DEAD-VAR>>)>
1011                  <COND (<TYPE? <3 .INST> ATOM DEAD-VAR>
1012                         <ADD-DEAD <REST .INST 2> .LIVES .SETTER>)>
1013                  <COND (<TYPE? <4 .INST> ATOM DEAD-VAR>
1014                         <ADD-DEAD <REST .INST 3> .LIVES .SETTER>)>)
1015                 (<==? .OP `SETRL>
1016                  <SET SETTER <CHTYPE <3 .INST> ATOM>>
1017                  <COND (<NOT <REM-LIST? .SETTER .LIVES>>
1018                         <SETG ANY-FLUSHED-INS T>
1019                         <PUT .INST 3 <CHTYPE .SETTER DEAD-VAR>>)>
1020                  <COND (<TYPE? <2 .INST> ATOM DEAD-VAR>
1021                         <ADD-DEAD <REST .INST 1> .LIVES .SETTER>)>
1022                  <COND (<TYPE? <4 .INST> ATOM DEAD-VAR>
1023                         <ADD-DEAD <REST .INST 3> .LIVES .SETTER>)>)
1024                 (<==? .OP `TEMP>
1025                  <MAPF %<>
1026                        <FUNCTION (T)
1027                           <COND (<TYPE? .T LIST>
1028                                  <REM-LIST <ATOM-PART .T> .LIVES>)>>
1029                        <REST .INST>>)
1030                 (<==? .OP `MAKTUP>
1031                  <MAPF %<>
1032                        <FUNCTION (T)
1033                           <COND (<==? .T => <MAPLEAVE>)
1034                                 (<TYPE? .T LIST>
1035                                  <REM-LIST <ATOM-PART .T> .LIVES>)>>
1036                        <REST .INST>>)
1037                 (<==? .OP `DISPATCH>
1038                  <COND (<TYPE? <2 .INST> ATOM DEAD-VAR>
1039                         <ADD-DEAD <REST .INST 1> .LIVES %<>>)>
1040                  <COND (<TYPE? <3 .INST> ATOM DEAD-VAR>
1041                         <ADD-DEAD <REST .INST 2> .LIVES %<>>)>)
1042                 (<AND <N==? .OP `FCN>
1043                       <N==? .OP `GFCN>
1044                       <N==? .OP `OPT-DISPATCH>
1045                       <N==? .OP `LOOP>
1046                       <N==? .OP `END>
1047                       <N==? .OP `ICALL>>
1048                  <SET TEM <MEMQ = <REST .INST>>>
1049                  <COND (.TEM
1050                         <SET SETTER <CHTYPE <2 .TEM> ATOM>>
1051                         <COND (<N==? .SETTER `STACK>
1052                                <COND (<AND <NOT <REM-LIST? .SETTER .LIVES>>
1053                                            <N==? .OP `SCALL>
1054                                            <N==? .OP `SYSOP>
1055                                            <N==? .OP `SYSCALL>>
1056                                       <SETG ANY-FLUSHED-INS T>
1057                                       <PUT .TEM 2 <CHTYPE .SETTER DEAD-VAR>>)>)>)
1058                        (ELSE <SET SETTER %<>>)>
1059                  <REPEAT ((RINST <REST .INST>) ONE)
1060                     <COND (<EMPTY? .RINST> <RETURN>)>
1061                     <SET ONE <1 .RINST>>
1062                     <COND (<OR <==? .ONE =>
1063                                <==? .ONE +>
1064                                <==? .ONE ->>
1065                            <SET RINST <REST .RINST 2>>)
1066                           (<TYPE? .ONE ATOM DEAD-VAR>
1067                            <ADD-DEAD .RINST .LIVES .SETTER>
1068                            <SET RINST <REST .RINST>>)
1069                           (<AND <==? .OP `CHTYPE>
1070                                 <TYPE? .ONE FORM>
1071                                 <NOT <LENGTH? .ONE 1>>
1072                                 <==? <1 .ONE> `TYPE>
1073                                 <TYPE? <2 .ONE> ATOM>>
1074                            <ADD-DEAD <REST .ONE> .LIVES .SETTER>
1075                            <SET RINST <REST .RINST>>)
1076                           (ELSE
1077                            <SET RINST <REST .RINST>>)>>)>)>
1078    .LIVES>
1079
1080 <DEFINE ADD-DEAD (RINST:<LIST <OR ATOM DEAD-VAR>> L:UVECTOR
1081                   SETTER:<OR ATOM FALSE>
1082                   "AUX" (ATM:ATOM <CHTYPE <1 .RINST> ATOM>))
1083    <COND (<AND <ADD-LIST? .ATM .L> <N==? .ATM .SETTER>>
1084           <1 .RINST <CHTYPE .ATM DEAD-VAR>>)>>
1085
1086 <DEFINE INSERT-DEADS (CODE:LIST VCODE:VECTOR "AUX" (RCODE:LIST .CODE))
1087    <MAPF %<>
1088          <FUNCTION (INST "AUX" DEADS:LIST FALL-DEADS:LIST JUMP-DEADS:LIST OP
1089                                TMPL:<OR FALSE LIST> BJL:<OR FALSE UVECTOR>)
1090             <COND (<TYPE? .INST BRANCH>
1091                    <SET DEADS <FIND-DEADS <B-INST .INST>>>
1092                    <SET FALL-DEADS <UV-TO-L <B-FALL-DEADS .INST>>>
1093                    <SET BJL <B-JUMP-DEADS .INST>>
1094                    <COND (.BJL
1095                           <SET JUMP-DEADS <UV-TO-L .BJL>>)
1096                          (ELSE <SET JUMP-DEADS ()>)>
1097                    <SET INST <B-INST .INST>:FORM>
1098                    ;"BEGIN TEMPORARY HACK"
1099                    ;<SET FALL-DEADS <INTERSECT-LISTS .FALL-DEADS .JUMP-DEADS>>
1100                    ;<SET JUMP-DEADS ()>
1101                    ;"END TEMOPRARY HACK"
1102                    <COND (<NOT <EMPTY? .JUMP-DEADS>>
1103                           <PUTREST <REST .INST <- <LENGTH .INST> 1>>
1104                                    ((`DEAD-JUMP !.JUMP-DEADS))>)>
1105                    <COND (<NOT <EMPTY? .FALL-DEADS>>
1106                           <PUTREST <REST .INST <- <LENGTH .INST> 1>>
1107                                    ((`DEAD-FALL !.FALL-DEADS))>)>
1108                    <COND (<NOT <EMPTY? .DEADS>>
1109                           <PUTREST .RCODE
1110                                    (<CHTYPE (`DEAD !.DEADS) FORM>
1111                                     !<REST .RCODE>)>
1112                           <SET RCODE <REST .RCODE>>)>
1113                    <SET RCODE <REST <SET CODE .RCODE>>>)
1114                   (<TYPE? .INST FORM>
1115                    <COND (<AND <NOT <EMPTY? .INST>>
1116                                <OR <AND <==? <SET OP <1 .INST>> `SET>
1117                                         <OR <==? <2 .INST> <3 .INST>>
1118                                             <TYPE? <2 .INST> DEAD-VAR>>>
1119                                    <AND <==? .OP `SETLR>
1120                                         <TYPE? <2 .INST> DEAD-VAR>>
1121                                    <AND <==? .OP `SETRL>
1122                                         <TYPE? <3 .INST> DEAD-VAR>>
1123                                    <AND <SET TMPL <MEMQ = .INST>>
1124                                         <TYPE? <2 .TMPL> DEAD-VAR>>>
1125                                <SETG ANY-FLUSHED-INS T>
1126                                <COND (<OR <==? .OP `CALL> <==? .OP `ACALL>>
1127                                       <PUTREST <REST .INST <- <LENGTH .INST>
1128                                                               <LENGTH .TMPL>
1129                                                               1>> ()>
1130                                       <>)
1131                                      (<OR <==? .OP `SCALL> <==? .OP `SYSOP>
1132                                           <==? .OP `SYSCALL>>
1133                                       <PUT .TMPL 2 <CHTYPE <2 .TMPL> ATOM>>
1134                                       <>)
1135                                      (<==? .OP `POP>
1136                                       <PUT .RCODE 1 '<`ADJ -1>>
1137                                       <SET RCODE <REST <SET CODE .RCODE>>>
1138                                       T)
1139                                      (ELSE
1140                                       <PUTREST .CODE
1141                                                <SET RCODE <REST .RCODE>>>
1142                                       T)>>)
1143                          (ELSE
1144                           <SET DEADS <FIND-DEADS .INST>>
1145                           <COND (<NOT <EMPTY? .DEADS>>
1146                                  <PUTREST .RCODE
1147                                           (<FORM `DEAD !.DEADS>
1148                                            !<REST .RCODE>)>
1149                                  <SET RCODE <REST .RCODE>>)>
1150                           <SET RCODE <REST <SET CODE .RCODE>>>)>)
1151                   (<NOT <AND <TYPE? .INST LABEL>
1152                              <TYPE? <SET INST <L-INST .INST>> FORM>
1153                              <NOT <EMPTY? .INST>>
1154                              <==? <1 .INST> `ENDIF>>>
1155                    <SET RCODE <REST <SET CODE .RCODE>>>)>>
1156          .VCODE>>
1157
1158 <DEFINE FIND-DEADS (INST:FORM "AUX" OP (PASSED=?:<OR FALSE <LIST ANY>> <>))
1159    <COND (<NOT <EMPTY? .INST>>
1160           <SET OP <1 .INST>>
1161           <MAPR ,LIST
1162                 <FUNCTION (RINST "AUX" (ONE <1 .RINST>))
1163                    <COND (<==? .ONE =>
1164                           <SET PASSED=? .RINST>
1165                           <MAPRET>)
1166                          (<AND .PASSED=?
1167                                <OR <==? .OP `CALL> <==? .OP `ACALL>>
1168                                <TYPE? .ONE DEAD-VAR>>
1169                           <PUTREST <REST .INST
1170                                          <- <LENGTH .INST>
1171                                             <LENGTH .PASSED=?>
1172                                             1>>
1173                                    ()>
1174                           <MAPSTOP>)
1175                          (<TYPE? .ONE DEAD-VAR>
1176                           <SET ONE <CHTYPE .ONE ATOM>>
1177                           <1 .RINST .ONE>
1178                           <MAPRET .ONE>)
1179                          (<AND <TYPE? .ONE FORM>
1180                                <==? .OP `CHTYPE>
1181                                <NOT <LENGTH? .ONE 1>>
1182                                <==? <1 .ONE> `TYPE>
1183                                <TYPE? <2 .ONE> DEAD-VAR>>
1184                           <2 .ONE <CHTYPE <2 .ONE> ATOM>>
1185                           <MAPRET <2 .ONE>>)
1186                          (ELSE <MAPRET>)>>
1187                 <REST .INST>>)
1188          (ELSE ())>>
1189
1190 <DEFINE UV-TO-L (UV:UVECTOR "AUX" (L:LIST ()) (TEMP-OFFS:FIX 0))
1191         <MAPF <>
1192               <FUNCTION (WD)
1193                    <COND (<N==? .WD 0>
1194                           <REPEAT ((TNO:FIX <+ .TEMP-OFFS 1>)
1195                                    (MSK:FIX 1))
1196                                   <COND (<N==? <ANDB .MSK .WD> 0>
1197                                          <SET L (<NTH ,NAME-UV .TNO> !.L)>
1198                                          <SET WD <XORB .WD .MSK>>
1199                                          <COND (<==? .WD 0> <RETURN>)>)>
1200                                   <SET TNO <+ .TNO 1>>
1201                                   <SET MSK <LSH .MSK 1>>>)>
1202                    <SET TEMP-OFFS <+ .TEMP-OFFS 32>>>
1203               .UV>
1204         .L>
1205
1206 <ENDPACKAGE>