mim/development/mim/vax/mimivx.s

   1 .set    version, 73
   2
   3 /* UNIX version */
   4 /* (begin long comment)
   5
   6 Various assembler requirements: here for reference:
   7
   8 RADIX CONTROL:
   9         leading 0 ==> octal
  10         no leading 0 ==> decimal
  11         leading 0X (0x) ==> hex
  12         floats, if I need them...
  13
  14 TEXT:
  15         'C ==> ascii value of C
  16         "string" ==> counted string (try this...)
  17
  18 LABELS:
  19         Lfoo labels are discarded
  20         n: (0 <= n <= 9) ==> local label, nb(ackwards) nf(orward) references
  21
  22 OPERATORS:
  23         + - * /  obvious
  24         % modulo
  25         (& and) (| or) (^ xor) (> right-shift) (< left-shift) (! or-not)
  26
  27 OTHER:
  28         .ALIGN n ==> align to n-zero boundary
  29         .SPACE n ==> N bytes of zeros are assembled
  30         .BYTE (.WORD .LONG .QUAD) expr, expr, expr, expr, ....
  31         .ASCII (.ASCIZ) string, string, string, ...
  32
  33         .SET symbol, value ==> enter SYMBOL into symbol table
  34
  35 !!!     use $ instead of #      !!!
  36 !!!     use * instead of @      !!!
  37
  38 (end comment) */
  39
  40
  41 /* Begin long comment about MDL
  42
  43 Register allocation:
  44
  45         TP (r13)        ;MDL stack
  46         FR (r12)        ;MDL frame
  47         MS (r11)        ;Current MSUBR pointer
  48
  49         r0              ;Type in type/value pair
  50         r1              ;Value
  51
  52 Memory layout: (addresses are in hex)
  53
  54 P0:             =========================
  55 0000 0000       I       dispatch        I
  56                 I        table          I
  57                 =========================
  58 0000 0200       I         MIMI          I
  59                 I         code          I
  60                 =========================
  61 000? ????       I      Pure space       I
  62                 =========================
  63 000? ????       I      FBIN space       I
  64                 =========================
  65 000? ????       I       MDL stack       I
  66                 I          ||           I
  67                 I          ||           I
  68                 I         \||/          I
  69                 I          \/           I
  70 3FFF FFFF       .........................
  71
  72 P1:             .........................
  73 4000 0000       I                       I
  74                 I          /\           I
  75                 I         /||\          I
  76                 I          ||           I
  77                 I          ||           I
  78 7FFF FAFF:      I       GC space        I
  79                 =========================
  80                 I       (1 Kword)       I
  81 7FFF FBFF:      I       SP stack        I
  82                 =========================
  83                 I        system         I
  84                 I       variables       I
  85 7FFF FFFF       I       (1 Kword)       I
  86                 =========================
  87
  88 (end long MDL comment)  */
  89
  90 /* definitions of system calls */
  91
  92         .set    _exit, 1
  93         .set    _fork, 2
  94         .set    _read, 3
  95         .set    _write, 4
  96         .set    _open, 5
  97         .set    _close, 6
  98 /*      .set    _wait, 7        */
  99         .set    _creat, 8
 100         .set    _link, 9
 101         .set    _unlink, 10
 102         .set    _exec, 11
 103         .set    _chdir, 12
 104 /*      .set    _time, 13       */
 105         .set    _mknod, 14
 106         .set    _chmod, 15
 107         .set    _chown, 16
 108         .set    _break, 17      /* seems to still exist */
 109 /*      .set    _stat, 18       */
 110         .set    _lseek, 19
 111         .set    _getpid, 20
 112         .set    _mount, 21
 113         .set    _umount, 22
 114 /*      .set    _setuid, 23     */
 115         .set    _getuid, 24
 116 /*      .set    _stime, 25      */
 117         .set    _ptrace, 26
 118 /*      .set    _alarm, 27      */
 119 /*      .set    _fstat, 28      */
 120 /*      .set    _pause, 29      */
 121 /*      .set    _utime, 30      */
 122 /*      .set    _stty, 31       */
 123 /*      .set    _gtty, 32       */
 124         .set    _access, 33
 125 /*      .set    _nice, 34       */
 126 /*      .set    _ftime, 35      */
 127         .set    _sync, 36
 128         .set    _kill, 37
 129         .set    _stat, 38
 130 /*      .set    _setpgrp, 39    */
 131         .set    _lstat, 40
 132         .set    _dup, 41
 133         .set    _pipe, 42
 134 /*      .set    _times, 43      */
 135         .set    _profil, 44
 136 /*      .set    _setgid, 46     */
 137         .set    _getgid, 47
 138 /*      .set    _signal, 48     */
 139         .set    _acct, 51
 140 /*      .set    _phys, 52       */
 141 /*      .set    _lock, 53       */
 142         .set    _ioctl, 54
 143         .set    _reboot, 55
 144 /*      .set    _mpx, 56        */
 145         .set    _symlink, 57
 146         .set    _readlink, 58
 147         .set    _execve, 59
 148         .set    _umask, 60
 149         .set    _chroot, 61
 150         .set    _fstat, 62
 151         .set    _getpagesize, 64
 152         .set    _mremap, 65
 153 /*      .set    _vfork, 66      */
 154 /*      .set    _vread, 67      */
 155 /*      .set    _vwrite, 68     */
 156         .set    _sbrk, 69
 157         .set    _sstk, 70
 158         .set    _mmap, 71
 159 /*      .set    _vadvise, 72    */
 160         .set    _vhangup, 76
 161 /*      .set    _vlimit, 77     */
 162         .set    _mincore, 78
 163         .set    _getgroups, 79
 164         .set    _setgroups, 80
 165         .set    _getpgrp, 81
 166         .set    _setpgrp, 82
 167         .set    _setitimer, 83
 168         .set    _wait, 84
 169         .set    _vswapon, 85
 170         .set    _getitimer, 86
 171         .set    _gethostname, 87
 172         .set    _sethostname, 88
 173         .set    _getdtablesize, 89
 174         .set    _dup2, 90
 175         .set    _getdopt, 91
 176         .set    _fcntl, 92
 177         .set    _select, 93
 178         .set    _setdopt, 94
 179         .set    _fsync, 95
 180         .set    _setpriority, 96
 181         .set    _socket, 97
 182         .set    _connect, 98
 183         .set    _accept, 99
 184         .set    _getpriority, 100
 185         .set    _send, 101
 186         .set    _recv, 102
 187         .set    _bind, 104
 188         .set    _setsockopt, 105
 189         .set    _listen, 106
 190         .set    _vtimes, 107
 191         .set    _sigvec, 108
 192         .set    _sigblock, 109
 193         .set    _sigsetmask, 110
 194         .set    _sigpause, 111
 195         .set    _sigstack, 112
 196         .set    _recvmsg, 113
 197         .set    _sendmsg, 114
 198         .set    _gettimeofday, 116
 199         .set    _getrusage, 117
 200         .set    _getsockopt, 118
 201         .set    _readv, 120
 202         .set    _writev, 121
 203         .set    _settimeofday, 122
 204         .set    _fchown, 123
 205         .set    _fchmod, 124
 206         .set    _recvfrom, 125
 207         .set    _setreuid, 126
 208         .set    _setregid, 127
 209         .set    _rename, 128
 210         .set    _truncate, 129
 211         .set    _ftruncate, 130
 212         .set    _flock, 131
 213         .set    _sendto, 133
 214         .set    _shutdown, 134
 215         .set    _socketpair, 135
 216         .set    _mkdir, 136
 217         .set    _rmdir, 137
 218         .set    _utimes, 138
 219         .set    _revoke, 140
 220         .set    _getpeername, 141
 221         .set    _gethostid, 142
 222         .set    _sethostid, 143
 223         .set    _getrlimit, 144
 224         .set    _setrlimit, 145
 225         .set    _killpg, 146
 226         .set    _setquota, 148
 227         .set    _quota, 149
 228         .set    _getsockname, 150
 229
 230 /* Random definitions */
 231
 232         .set upages, 12
 233         .set ubytes, upages*512
 234         .set topwds, 5
 235         .set sysbot, 0x7FFFFFFF-ubytes-topwds*4+1
 236         .set intflg, 0x7FFFFFFF-ubytes-3
 237         .set stkbot, 0x7FFFFFFF-ubytes-7
 238         .set stkmax, 0x7FFFFFFF-ubytes-11
 239         .set bindid, 0x7FFFFFFF-ubytes-15
 240         .set spsto, 0x7FFFFFFF-ubytes-19
 241         .set L_SET, 0
 242         .set O_RDONLY, 0
 243         .set O_WRONLY, 1
 244         .set O_RDWR, 2
 245         .set O_NDELAY, 4
 246         .set O_APPEND, 10
 247         .set O_CREAT, 01000
 248         .set O_TRUNC, 02000
 249         .set O_EXCL, 04000
 250         .set _chmk, 0xBC
 251         .set EINTR, 4
 252         .set ENOSPC, 28
 253         .set sig_int, 2
 254         .set sig_quit, 3
 255         .set sig_ill, 4
 256         .set sig_fpe, 8
 257         .set sig_bus, 10
 258         .set sig_segv, 11
 259         .set sig_sys, 12
 260         .set sig_pipe, 13
 261         .set sig_alrm, 14
 262         .set sig_urg, 16
 263         .set sig_tstp, 18
 264         .set sig_cont, 19
 265         .set sig_chld, 20
 266         .set sig_ttou, 22
 267         .set sig_io, 23
 268         .set sig_xcpu, 24
 269         .set sig_xfsz, 25
 270         .set tiocsetn, 0x8006740a
 271         .set tioclset, 0x8004747d
 272         .set tiocsetc, 0x80067411
 273         .set tiocsltc, 0x80067475
 274         .set wds_page, 256              /* words per page */
 275         .set byts_page, wds_page*4      /* bytes per page */
 276         .set byts_page_sh, -10
 277         .set gcsize, 250000             /* words of gc initially */
 278         .set gcsizb, gcsize*4           /* bytes of gc space */
 279         .set gcsizp, gcsize/wds_page    /* pages of gc space */
 280         .set gcfoff, 12                 /* offset into zone to point to gc */
 281         .set gcaoff, 44                 /* list of areas in zone */
 282         .set abot, 0
 283         .set amin, 4
 284         .set amax, 8                    /* offsets into area */
 285         .set tp_sizew, 100000           /* tp stack size (words) */
 286         .set tp_size, tp_sizew*4
 287         .set tp_buf, 6000               /* buffer above tp stack */
 288         .set pur_init, 52000            /* eventually enough to hold fbins */
 289         .set zlnt, 5                    /* elements in a zone vector */
 290         .set rlimit_stack, 3            /* parameter to set max stack area size
 291                                             which is gc space for us */
 292         .set rlimit_data, 2
 293         .set gcstart, 0x7FFFFAFF        /* start (top) of GC space */
 294         .set spstart, 0x7FFFFBFF        /* start (top) of system stack */
 295         .set hsize, 237                 /* atom hash table size */
 296         .set lhsize, hsize*2+2          /* longwords needed for htable */
 297
 298         .set minf.len, 10               /* length of minf vector */
 299         .set jmpa, 0x9f                 /* start of JMP abs instruction */
 300
 301
 302 /* Type code definitions */
 303
 304         .set dope, 040          /* Dope bit for stack things */
 305         .set dope_bit, 02000000
 306         .set mark_bit, 0x8000
 307
 308 /* bit definitions sometimes usefull */
 309         .set bit0,  000000000001
 310         .set bit1,  000000000002
 311         .set bit2,  000000000004
 312         .set bit3,  000000000010
 313         .set bit4,  000000000020
 314         .set bit5,  000000000040
 315         .set bit6,  000000000100
 316         .set bit7,  000000000200
 317         .set bit8,  000000000400
 318         .set bit9,  000000001000
 319         .set bit10, 000000002000
 320         .set bit11, 000000004000
 321         .set bit12, 000000010000
 322
 323         .set bit29, 004000000000
 324         .set bit30, 010000000000
 325         .set bit31, 020000000000
 326
 327 /* Primtypes */
 328
 329         .set pt.fix,0
 330         .set pt.list,1
 331         .set pt.rec,2
 332         .set pt.bytes,4
 333         .set pt.str,5
 334         .set pt.uvec,6
 335         .set pt.vec,7
 336         .set pt.bits,7
 337
 338 /* types - coded so that rightmost 3 bits are primtype */
 339
 340
 341         .set    t.any, 0        /* not REALLY a type, but.. */
 342
 343         .set    shft,0100       /* used to shift type code left */
 344
 345         .set    t.unb, pt.fix+shft*0
 346         .set    t.fix, pt.fix+shft*1
 347         .set    t.char, pt.fix+shft*2
 348         .set    t.float, pt.fix+shft*3
 349
 350         .set    t.list, pt.list+shft*4
 351         .set    t.false, pt.list+shft*5
 352         .set    t.decl, pt.list+shft*6
 353
 354         .set    t.str, pt.str+shft*7
 355         .set    t.mcode, pt.uvec+shft*8
 356         .set    t.vec, pt.vec+shft*9
 357         .set    t.msubr, pt.vec+shft*10
 358         .set    t.tat, pt.vec+shft*34           /* out of order */
 359
 360         .set    t.frame, pt.rec+shft*11
 361         .set    t.bind, pt.rec+shft*12
 362         .set    t.atom, pt.rec+shft*13
 363         .set    t.obl, pt.rec+shft*14
 364         .set    t.gbind, pt.rec+shft*15
 365         .set    t.qfram, pt.rec+shft*33         /* out of order */
 366
 367         .set    t.form, pt.list+shft*16
 368         .set    t.typc, pt.fix+shft*17
 369         .set    t.term, pt.fix+shft*18
 370         .set    t.segm, pt.list+shft*19
 371         .set    t.defer, pt.list+shft*20
 372         .set    t.func, pt.list+shft*21
 373         .set    t.macro, pt.list+shft*22
 374         .set    t.chan, pt.vec+shft*23
 375         .set    t.entry, pt.vec+shft*24
 376         .set    t.adecls, pt.vec+shft*25
 377         .set    t.offs, pt.vec+shft*26
 378         .set    t.lval, pt.rec+shft*27
 379         .set    t.gval, pt.rec+shft*28
 380         .set    t.link, pt.rec+shft*29
 381         .set    t.tuple, pt.vec+shft*30
 382         .set    t.uvec, pt.uvec+shft*31
 383         .set    t.imsub, pt.vec+shft*32
 384         .set    t.sdtab, pt.vec+shft*35
 385         .set    t.diskc, pt.vec+shft*36
 386         .set    t.mudch, pt.vec+shft*37
 387         .set    t.word, pt.fix+shft*38
 388         .set    t.pcode, pt.uvec+shft*39
 389         .set    t.zone, pt.vec+shft*40
 390         .set    t.gcpar, pt.uvec+shft*41
 391         .set    t.area, pt.uvec+shft*42
 392         .set    t.sframe, pt.rec+shft*43
 393         .set    t.bytes, pt.bytes+shft*44
 394         .set    t.typw, pt.fix+shft*45
 395         .set    t.qsfra, pt.rec+shft*46
 396         .set    t.bits, pt.fix+shft*47
 397         .set    t.kentry, pt.vec+shft*48
 398         .set    t.fretyp, 49            /* first type for used-defined */
 399
 400 /* Internal structures */
 401
 402   /* object:    (may be added to xx.obj to get real offset) */
 403         .set    o.typ, 0
 404         .set    o.cnt, 2
 405         .set    o.val, 4
 406
 407         .set    ot, 0   /* shorthand alternates for object offsets */
 408         .set    oc, 2
 409         .set    ov, 4
 410
 411   /* dope:      (usually added to xx.dope to find real offset) */
 412         .set    dp.typ, 0       /* type of this thing */
 413         .set    dp.len, 2       /* length */
 414         .set    dp.gc, 4        /* GC word */
 415
 416   /* frame:     (stack offsets) */
 417         .set    fr.act, -4      /* relative PC stored for AGAIN */
 418           .set    fr.ffb, -1
 419           .set    ffbit, 0200   /*
 420                  note that the MSB of fr.act flags glued frames
 421                 this is a kludge, but it works.  The bit is on
 422                 iff the frame is NOT a glued frame. */
 423         .set    fr.tp, -6       /* TP to restore on AGAIN       (2 bytes) */
 424         .set    fr.sp, -8       /* SP pointer for frame         (2 bytes) */
 425         .set    fr.fra, -12     /* previous frame               (4 bytes) */
 426         .set    fr.id, -14      /* unique frame ID              (2 bytes) */
 427         .set    fr.arg, -16     /* number of args               (2 bytes) */
 428         .set    fr.pc, -20      /* return PC                    (4 bytes) */
 429         .set    fr.msa, -24     /* current msubr                (4 bytes) */
 430         .set    fr.head, -28    /* header word                  (4 bytes) */
 431
 432         .set    fr.len, 14      /* length of frame in 16-bit words */
 433
 434   /* glued frame: */
 435
 436         .set    gfr.pfr, -4     /* previous frame (check it...) */
 437 /*  defined in frame... .set    fr.ffb, -1      */
 438         .set    gfr.fra, -8     /* previous not-glued  frame (check...) */
 439         .set    gfr.pc, -12     /* return PC */
 440         .set    gfr.typ, -14    /* type         (2 bytes)       */
 441
 442         .set    gfr.len, 7      /* length of glued frame in 16-bit words */
 443
 444
 445   /* cell: */
 446         .set    c.ptr, 0        /* pointer to rest */
 447         .set    c.obj, 4        /* cell object */
 448
 449   /* vector, uvector, string:
 450                 these are arrays of [objects/ fixes/ bytes]
 451                 followed by the dope word       */
 452
 453   /* atom: */
 454         .set    a.gbind, 0      /* global binding       (4 bytes) */
 455         .set    a.lbind, 4      /* local binding        (4 bytes) */
 456         .set    a.name, 8       /* name                 (8 bytes) */
 457         .set    a.obl, 16       /* oblist               (4 bytes) */
 458         .set    a.dope, 20      /* dope words           (n bytes) */
 459
 460         .set    a.len, 5        /* length in words */
 461
 462   /* gbind: */
 463         .set    gb.obj, 0       /* object               (8 bytes) */
 464         .set    gb.atom, 8      /* atom                 (4 bytes) */
 465         .set    gb.decl, 12     /* decl                 (8 bytes) */
 466         .set    gb.dope, 20     /* dope words           (n bytes) */
 467
 468   /* lbind: */
 469         .set    lb.hdr, -4      /* header (only when on stack) (4 bytes) */
 470
 471         .set    lb.obj, 0       /* object               (8 bytes) */
 472         .set    lb.atom, 8      /* atom                 (4 bytes) */
 473         .set    lb.decl, 12     /* decl                 (8 bytes) */
 474         .set    lb.prev, 20     /* previous binding     (4 bytes) */
 475         .set    lb.last, 24     /* last binding for this atom (4 bytes) */
 476         .set    lb.bid, 28      /* bind ID              (4 bytes) */
 477         .set    lb.dope, 32     /* dope words           (n bytes) */
 478
 479         .set    lb.head, -4     /* hdr from pointer */
 480         .set    ln.bind, 8      /* length of local binding (longwords) */
 481         .set    ln.lbind, 16    /* length in words */
 482         .set    ln.bindb, 32
 483
 484   /* msubr: */
 485         .set    ms.im, 0        /* imsubr atom */
 486         .set    ms.name, 8      /* name atom */
 487         .set    ms.decl, 16     /* decl */
 488         .set    ms.off, 24      /* offset into msubr code */
 489
 490   /* imsubr: */
 491         .set    im.code, 0      /* pointer to code uvector */
 492         .set    im.atom, 4      /* atom */
 493         .set    im.free, 12     /* beginning of rest of junk */
 494
 495 /* Ascii characters */
 496         .set    chtab, 011
 497         .set    chlf, 012
 498         .set    chvt, 013
 499         .set    chff, 014
 500         .set    chcr, 015
 501         .set    chspc, 040
 502
 503 /* GC definitions       */
 504
 505         .set    gcpoff, 4
 506
 507         .text
 508 /* put in jump at address 0 */
 509 txtstr: .word   0               /* it seems that first word is skipped */
 510         jmp     booter
 511         .align  2               /* start dispatch table at 8 */
 512
 513 /* dispatch table - each entry is a longword - referenced by all code */
 514 /* nop instructions used to align longwords */
 515         brw     iret
 516         nop
 517         brw     iframe
 518         nop
 519         brw     mcall
 520         nop
 521         brw     icons
 522         nop
 523         brw     incall
 524         nop
 525         brw     igets
 526         nop
 527         brw     isets
 528         nop
 529         brw     ifixbn
 530         nop
 531         brw     iunbind
 532         nop
 533         brw     record
 534         nop
 535         brw     bvecto
 536         nop
 537         brw     blist
 538         nop
 539         brw     ibind
 540         nop
 541         brw     ublock
 542         nop
 543         brw     iactiv
 544         nop
 545         brw     iagain
 546         nop
 547         brw     retry
 548         nop
 549         brw     irtuple
 550         nop
 551         brw     ituple
 552         nop
 553         brw     lckint
 554         nop
 555         brw     newtype
 556         nop
 557         brw     open
 558         nop
 559         brw     close
 560         nop
 561         brw     read
 562         nop
 563         brw     print
 564         nop
 565         brw     isave
 566         nop
 567         brw     irestor         /* brw  irestor */
 568         nop
 569         brw     illdis          /* brw  random  */
 570         nop
 571         brw     comper
 572         nop
 573         brw     birec
 574         nop
 575         brw     nthu
 576         nop
 577         brw     restu
 578         nop
 579         brw     putu
 580         nop
 581         brw     nthr
 582         nop
 583         brw     putr
 584         nop
 585         brw     backu
 586         nop
 587         brw     topu
 588         nop
 589         brw     illdis          /* ireset ?? */
 590         nop
 591         brw     iatic
 592         nop
 593         brw     iargs
 594         nop
 595         brw     ciemp
 596         nop
 597         brw     cinth
 598         nop
 599         brw     cimon
 600         nop
 601         brw     cirst
 602         nop
 603         brw     cigas
 604         nop
 605         brw     cigvl
 606         nop
 607         brw     swnxt
 608         nop
 609         brw     nexts
 610         nop
 611         brw     relu            /* brw  relu    */
 612         nop
 613         brw     relr            /* brw  relr    */
 614         nop
 615         brw     rell            /* brw  rell    */
 616         nop
 617         brw     illdis          /* brw  conten  */
 618         nop
 619         brw     imarkr          /* brw  imarkr  */
 620         nop
 621         brw     imarkrq         /* brw  imarkrq */
 622         nop
 623         brw     illdis          /* brw  syscalx */
 624         nop
 625         brw     quit            /* brw  quit    */
 626         nop
 627         brw     tmptbl
 628         nop
 629         brw     setzon          /* brw  setzon  */
 630         nop
 631         brw     legal
 632         nop
 633         brw     unwcnt
 634         nop
 635         brw     mpages
 636         nop
 637         brw     illdis          /* brw  iputs   */
 638         nop
 639         brw     iacall
 640         nop
 641         brw     syscal
 642         nop
 643         brw     rntime
 644         nop
 645         brw     sframe
 646         nop
 647         brw     mretur
 648         nop
 649         brw     typew
 650         nop
 651         brw     typewc
 652         nop
 653         brw     savtty
 654         nop
 655         brw     dfatal
 656         nop
 657         brw     gettty
 658         nop
 659         brw     dopipe
 660         nop
 661         brw     ugverr
 662         nop
 663         brw     movstk
 664         nop
 665         brw     getstk
 666         nop
 667         brw     uublock
 668         nop
 669         brw     sblock
 670         nop
 671         brw     usblock
 672         nop
 673         brw     iassq
 674         nop
 675         brw     ilval
 676         nop
 677         brw     iset
 678         nop
 679         brw     bigstk
 680
 681 /* Utility routines for following... */
 682
 683 /* Unglue a frame, returns new frame pointer in r12 */
 684
 685 ungfrm: tstb    fr.ffb(r12)     /* is it already real frame? */
 686         blss    1f              /* yes, return */
 687          movl   fr.act(r12),r12 /* otherwise, chase pointer */
 688          jbr    ungfrm          /* iterate */
 689 1:      rsb                     /* return to caller */
 690
 691 /* Print MDEPTH spaces on terminal */
 692
 693 prspac: pushl   r2              /* save a temp */
 694         movl    mdepth,r2       /* get indentation count */
 695 1:      movl    $spaces,r1      /* address of spaces */
 696         movl    $1,r3           /* just print one */
 697         clrl    r5              /* print to tty */
 698         bsbw    print
 699         sobgtr  r2,1b           /* loop for all spaces to print */
 700         movl    (sp)+,r2        /* restore register */
 701         rsb
 702
 703
 704 /************************************************************************
 705 *                                                                       *
 706 *               .subtitle Stack Operations                              *
 707 *                                                                       *
 708 *               frame, mcall, bind, legal, args, tuple, return          *
 709 *               unbind, retry, activation, rtuple, again                *
 710 *                                                                       *
 711 *************************************************************************/
 712
 713 /* iset - set lval.  May call SET (via I$EICC) if needs to make
 714    top-level binding.  Takes value in r2, r3; atom in r0 */
 715 iset:   movl    a.lbind(r0),r1
 716          jeql   isetgr                  /* no lbind pointer, need top-level */
 717         cmpl    lb.bid(r0),bindid       /* right bindid? */
 718          jneq   isetgr1                 /* no, try to find a good one */
 719 isetdn: movq    r2,lb.obj(r1)
 720         movq    r2,r0
 721         rsb
 722 isetgr1:
 723         bsbw    iassq                   /* get lbind pointer in r1 */
 724         tstl    r1
 725          jneq   isetdn                  /* go do it */
 726 isetgr: subl3   (sp),im.code+ov(r11),(sp)
 727         movl    ecall,r1
 728          jeql   noeicc
 729         bsbw    iframe
 730         movl    $(a.len<17+t.atom),(r13)+
 731         movl    r0,(r13)+
 732         movq    r2,(r13)+
 733         movl    $2,r0
 734         bsbw    mcallz
 735         subl3   (sp),im.code+ov(r11),(sp)
 736         rsb
 737
 738 /* lval - takes atom in 0, returns value in 0 and 1.  Calls
 739 EICC if fails, lets loser erret value from that. */
 740 ilval:  movl    a.lbind(r0),r1
 741          jeql   lvalls
 742         cmpl    lb.bid(r1),bindid
 743          jneq   lvalgr
 744         tstl    lb.obj(r1)
 745          jeql   lvalls
 746         movq    lb.obj(r1),r0
 747         rsb
 748 lvalgr: bsbw    iassq           /* try to get an lbind */
 749         tstl    r1
 750          jeql   lvalls
 751         movq    lb.obj(r1),r0
 752         rsb
 753 lvalls: subl3   (sp),im.code+ov(r11),(sp)
 754         movl    ecall,r1
 755          jeql   noeicc
 756         bsbw    iframe
 757         movl    $(a.len<17+t.atom),(r13)+
 758         movl    r0,(r13)+
 759         movl    $1,r0
 760         bsbw    mcallz
 761         subl3   (sp),im.code+ov(r11),(sp)
 762         rsb
 763
 764 /* assigned? - return 0 or lbind pointer in r1, given atom in r0.
 765    saves all registers except 0*/
 766 iassq:  movl    a.lbind(r0),r1          /* get lbind pointer */
 767          jeql   iassfl                  /* are none, lose */
 768         cmpl    lb.bid(r1),bindid       /* bindid OK? */
 769          jneq   iassgr                  /* no, grovel obscenely */
 770         tstl    lb.obj(r1)              /* check type */
 771          jneq   iasswn                  /* not unbound, so win */
 772 iassfl: clrl    r1
 773 iasswn: rsb
 774
 775 /* come here if bindid doesn't match.  Have to search binding chain
 776    for right thing. */
 777 iassgr: pushl   r2
 778         clrl    r2              /* flag */
 779         movl    spsto,r1        /* get binding chain */
 780          jeql   iassg1          /* empty */
 781 1:      cmpl    r0,lb.atom(r1)  /* same atom? */
 782          jeql   iassex          /* see if has lval in it */
 783         movl    lb.prev(r1),r1  /* previous binding */
 784          jneq   1b
 785         tstl    r2
 786          jneq   iassgfl
 787 iassg1: incl    r2
 788         movl    tbind,r1
 789          jneq   1b
 790 iassgfl: clrl   r1
 791 2:      movl    (sp)+,r2
 792         rsb
 793 iassex: tstl    lb.obj(r1)      /* see if not an unbound */
 794          jeql   iassgfl         /* lose */
 795         brb     2b              /* win */
 796
 797 /* ibind - push a binding
 798 * call:
 799 *       r1/ lbind
 800 * return:
 801 *       r1/ new binding
 802 *       (binding pushed on stack)
 803 *       (saves all registers)           */
 804
 805 ibind:  movl    $(ln.lbind+2)<16+dope+t.bind,(r13)+ /* push bind header > */
 806         movl    r13,r1          /* save tp now */
 807         clrq    (r13)+
 808         clrq    (r13)+          /* push a bunch of 0's (4 long words)*/
 809         clrq    (r13)+
 810         clrq    (r13)+          /* 4 more word, sigh */
 811         movl    spsto,-12(r13)  /* store current binding */
 812         movl    r1,spsto        /* this is current binding now */
 813         rsb                     /* return */
 814
 815 /* sframe - generate a segment frame (same as frame...) */
 816
 817 sframe: movl    $fr.len<16+dope+t.sframe, (r13)+   /* push frame header */
 818         brb     1f
 819
 820 /* iframe - generate an empty frame
 821 * call:
 822 *       (no arguments)
 823 * return:
 824 *       <empty frame has been pushed on TP stack>       */
 825
 826 iframe: movl    $fr.len<16+dope+t.frame, (r13)+ /* push frame header */
 827 1:      clrq    (r13)+
 828         clrq    (r13)+          /* zero rest of frame */
 829         clrq    (r13)+          /* zero rest of frame */
 830         bisb2   $ffbit,fr.ffb(r13)      /* light full-frame bit */
 831         rsb
 832
 833 /* mcall - call an msubr
 834 * call:
 835 *       r0/ # args
 836 *       r1/ MSUBR being called
 837 *
 838 * returns: (from msubr, eventually)
 839 *       r0/ type
 840 *       r1/ value               */
 841
 842 mcallz: movl    (sp)+,r2        /* get absolute return PC */
 843         jmp     mcallx          /* and go for it */
 844
 845 mcall:  tstl    mtrace          /* waste a whole word */
 846          beql   1f              /* don't want a trace, skip it */
 847
 848         pushr   $bit0+bit1+bit3+bit5 /* save registers used for print */
 849         incl    mdepth          /* nest count for printing spaces */
 850         pushl   r1              /* save atom pointer */
 851         bsbw    prspac          /* print many spaces */
 852         movl    $gtrt,r1        /* print greter-than on call */
 853         movl    $1,r3           /* single character */
 854         clrl    r5              /* to tty */
 855         bsbw    print
 856         movl    (sp)+,r1        /* restore atom pointer */
 857         movzwl  10(r1),r3       /* get character count */
 858         movq    8(r1),r0        /* string pointer */
 859         clrl    r5              /* channel 0 */
 860         bsbw    print           /* print MSUBR name */
 861         movl    $crlf,r1
 862         movl    $2,r3           /* 2 characters */
 863         clrl    r5              /* to terminal */
 864         bsbw    print           /* print crlf */
 865         popr    $bit0+bit1+bit3+bit5 /* restore dem registers */
 866
 867 1:      subl3   (sp)+,im.code+ov(r11),r2         /* get return PC from sp
 868                                                     and relativize it */
 869 mcallx: movl    a.gbind(r1),r3  /* get global binding of atom */
 870          jneq   1f
 871 gongs:    jmp   calngs          /*  none, complain */
 872
 873 1:      cmpw    ot+gb.obj(r3),$t.msubr /* is it an msubr? */
 874          jneq   gongs           /*  no, complain */
 875         movl    ov+gb.obj(r3),r4 /* get value (msubr) into r4 */
 876                                 /* drop through into ICRET */
 877
 878 icret:  movl    ov+ms.im(r4),r5 /* get imsubr atom from msubr */
 879         movl    a.gbind(r5),r10 /* its global binding */
 880          jneq   1f
 881 comgo:    bsbw  comper          /*  none - compiler error */
 882 1:      cmpw    ot+gb.obj(r10),$t.imsub /* is it an IMSUBR? */
 883          jneq   comgo           /*  NO, compiler blew it */
 884         movl    ov+gb.obj(r10),r11 /* mvector to MS */
 885         movl    r12,r7          /* save frame in case it we change it */
 886 icret1:
 887         bsbw    ungfrm          /* chase down real frame */
 888
 889         movl    spsto,r3        /* check spsto */
 890          beql   1f              /* if zero, dont relativize */
 891         subl2   r12,r3          /* relative to frame */
 892 1:      movw    r3,fr.sp(r12)   /* save current SP */
 893         movl    r2,fr.pc(r12)   /* save return PC */
 894         ashl    $3,r0,r3        /* number of bytes needed for arguments */
 895                                 /* CHANGE TO NEW FRAME */
 896         subl3   r3,r13,r12      /* new fr ptr now in FR */
 897         movl    r4,fr.msa(r12)  /* store pointer to new MSUBR in NEW frame */
 898         movl    r7,fr.fra(r12)  /* pointer to previous frame */
 899         incl    framid          /* bump frame id */
 900         movw    framid,fr.id(r12) /* and store in new frame */
 901         movw    r0,fr.arg(r12)  /* store number of args */
 902
 903         addl3   ms.off+ov(r4),im.code+ov(r11),r8        /* add offset */
 904         tstl    intflg          /* any interrupts */
 905          jneq   1f              /* yes, handle them instead */
 906 2:      jmp     (r8)            /* and jump to code... finally! */
 907
 908 1:      tstl    ingc            /* dont int if in gc */
 909          jneq   2b
 910         movl    $t.fix,(r13)+
 911         movl    r0,(r13)+       /* save number of args */
 912         movl    $t.fix,(r13)+
 913         subl3   r8,im.code+ov(r11),(r13)+       /* save pc */
 914 intlop: ffs     $0,$32,intflg,r8
 915          jeql   noincl          /* seems unlikely */
 916         pushr   $bit0+bit1
 917         locc    r8,intlen,intb1
 918          jneq   4f
 919         popr    $bit0+bit1
 920         brw     noincl          /* muddle doesn't know about it */
 921 4:      bsbw    iframe
 922         movl    $t.fix,(r13)+   /* call with correct args */
 923         movzbl  intb2(r0),(r13)+ /* pick up muddle interrupt number */
 924         popr    $bit0+bit1
 925         movl    icall,r1        /* get pointer to int routine */
 926          jeql   losint          /* loser */
 927
 928         ashl    r8,$1,r8
 929         bicl2   r8,intflg       /* clear intflg */
 930         movl    $1,r0
 931         bsbw    mcallz          /* call interrupt handler */
 932         tstl    intflg
 933          jneq   intlop          /* more to come */
 934         subl3   -(r13),im.code+ov(r11),r8
 935         subl2   $4,r13
 936         movl    -(r13),r0
 937         subl2   $4,r13
 938         jmp     (r8)
 939
 940 noincl: ashl    r8,$1,r8
 941         bicl2   r8,intflg
 942          jneq   intlop
 943         subl3   -(r13),im.code+ov(r11),r8
 944         subl2   $4,r13
 945         movl    -(r13),r0
 946         subl2   $4,r13
 947         jmp     (r8)
 948
 949 losint: movl    $intlos,r1
 950         movl    lintlos,r3
 951         clrl    r5
 952         bsbw    print
 953         brw     die
 954
 955 /* ifixbn - fix binding
 956 * call:
 957 *
 958 * return:
 959 *       (must save ALL registers)       */
 960
 961 ifixbn: pushl   r0              /* save registers r0,r1 */
 962         pushl   r1
 963         movl    spsto,r0        /* current binding pointer to r0 */
 964 1:      cmpl    r0,r12          /* compare to current frame */
 965          blss   2f
 966         movl    lb.atom(r0),r1  /* get atom */
 967         movl    r0,a.lbind(r1)  /* rebind it */
 968         movl    lb.prev(r0),r0  /* and chain */
 969         brb     1b
 970
 971 2:      movl    (sp)+,r1                /* restore work registers */
 972         movl    (sp)+,r0
 973         rsb
 974
 975
 976 /* ilegal - determine legality of object
 977 * call:
 978 *       r0/ count,,type
 979 *       r1/ value
 980 * return:
 981 *       r0/ type (fix=true) (false=false)
 982 *       (must save registers) */
 983
 984 legal:  cmpw    r0,$t.frame     /* frame? */
 985          jeql   lglfrm          /*  yes, test it */
 986         cmpw    r0,$t.bind      /* binding? */
 987          jeql   lglbnd          /*  ok, test that */
 988         pushr   $bit2+bit3
 989         bicl3   $0xFFFFFFF8,r0,r2
 990         caseb   r2,$0,$7
 991 lgltab: .word   lgltru-lgltab
 992         .word   lgltru-lgltab
 993         .word   lgltru-lgltab
 994         .word   lgltru-lgltab
 995         .word   lglstr-lgltab
 996         .word   lglstr-lgltab
 997         .word   lgluvc-lgltab
 998         .word   lgltup-lgltab
 999 lgltru: popr    $bit2+bit3
1000         movl    $t.fix,r0       /* all else is legal */
1001         rsb                     /* so report that */
1002
1003 lglstr: ashl    $-16,r0,r2      /* get length of string */
1004         addl2   r2,r1
1005         cmpl    r1,tpmax
1006          jgtr   lgltru
1007         cmpl    r1,r13
1008          jgtr   lgllos
1009         cmpl    r1,tpstart
1010          jlss   lgltru
1011 /* frob is on stack */
1012         bbc     $0,r1,1f
1013         incl    r1              /* point to halfword */
1014 1:      tstw    (r1)
1015          jneq   lgltst
1016         addl2   $2,r1           /* now we're at the dope word */
1017 lgltst: bitl    $dope,(r1)      /* is dope bit set? */
1018          jeql   lgllos          /* no, lose */
1019         movzwl  2(r1),r2
1020         ashl    $2,r2,r2
1021         subl3   r2,r1,r2
1022         cmpl    (r1),4(r2)      /* compare the dope words */
1023          jeql   lgltru
1024 lgllos: popr    $bit2+bit3
1025         movzwl  $t.false,r0
1026         clrl    r1
1027         rsb
1028 lgluvc: ashl    $-14,r0,r2      /* length in bytes */
1029         addl2   r2,r1           /* go to dope word */
1030         cmpl    r1,tpmax        /* check stack stuff */
1031          jgtr   lgltru
1032         cmpl    r1,tpstart
1033          jlss   lgltru
1034         cmpl    r1,r13
1035          jgtr   lgllos
1036         brb     lgltst          /* hit common code */
1037
1038 lglfrm: cmpl    r1,r13          /* check for inbounds */
1039          jgtr   lglfls          /* return false */
1040         cmpl    r1,tpstart
1041          jlss   lglfls
1042         cmpl    fr.head(r1),$fr.len<16+dope+t.frame   /* check frame header */
1043          jeql   lglwin          /* lose return false */
1044         cmpl    fr.head(r1),$fr.len<16+dope+t.sframe
1045          jneq   lglfls
1046 lglwin: movl    $t.fix,r0
1047         clrl    r1
1048         rsb
1049
1050 lglbnd: cmpl    r1,tpmax
1051          jgtr   lglwin          /* case of top-level lbind */
1052         cmpl    r1,r13
1053          jgtr   lglfls
1054         cmpl    r1,tpstart
1055          jlss   lglfls
1056         cmpl    lb.head(r1),$(ln.lbind+2)<16+dope+t.bind        /* bind hdr? */
1057          jeql   lglwin
1058
1059 lglfls: movl    $t.false,r0
1060         clrl    r1
1061         rsb
1062 lgltup: cmpl    r1,tpmax
1063          jgtr   lgltru
1064         cmpl    r1,r13
1065          jgtr   lgllos
1066         cmpl    r1,tpstart
1067          jlss   lgltru
1068 /* Now know it points to valid stack area */
1069         cmpl    fr.head(r1),$fr.len<16+dope+t.frame     /* args of frame */
1070          jeql   lgltru          /* this wins */
1071         cmpl    fr.head(r1),$fr.len<16+dope+t.sframe
1072          jeql   lgltru
1073         bicl2   $0xFFFF,r0      /* kill type */
1074         ashl    $2-16,r0,r0     /* word index */
1075         cmpw    (r1)[r0],$t.tuple+dope
1076          jeql   lgltru
1077         cmpw    (r1)[r0],$t.tuple
1078          jeql   lgltru
1079         cmpw    (r1)[r0],$t.vec+dope
1080          jeql   lgltru
1081
1082 /* here to see if rested args of frame */
1083
1084         movl    r12,r2          /* point to current frame */
1085
1086 lgltu1: tstb    fr.ffb(r2)      /* is this glued? */
1087          blss   1f
1088           movl  fr.act(r2),r2   /* loop back */
1089            jbr  lgltu1
1090
1091 1:      cmpl    r1,r2           /* if tuple pntr is above frame,
1092                                     this could be it */
1093          jgtr   lgltu2
1094         movl    fr.fra(r2),r2   /* previous frame */
1095         jbr     lgltu1
1096
1097 lgltu2: movaw   (r1)[r0],r1     /* rest given tuple to its end */
1098         movzwl  fr.arg(r2),r0   /* get # of args from frame */
1099         ashl    $3,r0,r0        /* change from objs to bytes */
1100         addl2   r0,r2           /* rest it to its end */
1101         cmpl    r2,r1           /* same end, therefore same legal tuple */
1102          jeql   lgltru
1103         brw     lgllos
1104
1105 /* iargs - return argument tuple for a frame
1106 * call:
1107 *       r1/ frame
1108 * return:
1109 *       r0/ type
1110 *       r1/ value
1111 *       (may mung all registers)
1112 *               (but doesn't) */
1113
1114 iargs:  movl    fr.arg-2(r1),r0 /* get count of args to LEFT HALF (kludge) */
1115         movw    $t.tuple,r0     /* new type word */
1116         rsb             /* r1 (frame pointer) points to tuple already */
1117
1118
1119 /* igets - codes:       (1 args) (2 oblist) (3 bind) (4 ecall) (5 ncall)
1120 *               (6 uwatm) (7 pagptr) (8 minf) (9 icall) (10 mapper)
1121 *               (11 envir) (12 argv) (13 homstr)
1122 * call:
1123 *       r1/ code (see above)
1124 * return:
1125 *       r0/ type
1126 *       r1/ value
1127 *       (saves all registers) */
1128
1129 igets:  caseb   r1,$1,$16       /* dispatch on type */
1130 getab:  .word   getarg-getab
1131         .word   getobl-getab
1132         .word   getbnd-getab
1133         .word   gecall-getab
1134         .word   gncall-getab
1135         .word   guwatm-getab
1136         .word   gpgptr-getab
1137         .word   getmnf-getab
1138         .word   gicall-getab
1139         .word   gmappe-getab
1140         .word   genvir-getab
1141         .word   gargv-getab
1142         .word   ghomst-getab
1143         .word   grunin-getab
1144         .word   gtbind-getab
1145         .word   gtingc-getab
1146         bsbw    comper          /* should never reach this */
1147
1148 gtingc: movzwl  $t.fix,r0
1149         movl    ingc,r1
1150         rsb
1151
1152 gtbind: movq    tbindt,r0
1153         rsb
1154
1155 getarg: movzwl  fr.arg(r12),r1  /* get number of args */
1156         movzbl  $t.fix,r0       /* and type */
1157         rsb
1158
1159 grunin: movzwl  $t.fix,r0
1160         movl    runint,r1
1161         rsb
1162
1163 getobl: movq    topobl,r0       /* type, value */
1164         rsb
1165
1166 getbnd: movl    spsto,r1        /* current binding */
1167         movl    $(ln.lbind<16+t.bind),r0 /* > type word */
1168         rsb
1169
1170 gecall: movl    ecall,r1        /* get current ecall */
1171         brb     retatm          /* and return atom */
1172
1173 gncall: movl    ncall,r1        /* current ncall */
1174         brb     retatm
1175
1176 gicall: movl    icall,r1        /* current icall */
1177         brb     retatm
1178
1179 guwatm: movl    uwatm,r1        /* current uwatom */
1180 retatm: movl    $(a.len<17+t.atom),r0 /* > type word */
1181         rsb
1182
1183 gpgptr: movq    pagptr,r0       /* current page pointer */
1184         rsb
1185
1186 getmnf: movl    minf,r1         /* current minf */
1187         movl    $(minf.len<16+t.uvec),r0 /* > type */
1188         rsb
1189
1190 gmappe: movl    mapper,r1       /* current mapper */
1191         brb     retatm
1192
1193 /* Can clobber r0,r1 */
1194 genvir: movl    envbeg,r0       /* Start of environment vec (set up by booter) */
1195         clrl    r1
1196         pushr   $bit2+bit3
1197 3:      tstl    (r0)            /* Is it zero? */
1198         beql    6f              /* Yes, done */
1199         movl    (r0),r2         /* Get string pointer */
1200         clrl    r3              /* for length */
1201 4:      tstb    (r2)            /* Found 0? */
1202         beql    5f              /* Yes, push a string pointer */
1203         incl    r2              /* No, point to next byte */
1204         aobleq  $1024,r3,4b     /* Aos count, try again */
1205 5:      movw    $t.str,(r13)+   /* Push a type */
1206         movw    r3,(r13)+       /* Push a length */
1207         movl    (r0),(r13)+     /* Push a value */
1208         addl2   $4,r0
1209         aobleq  $1024,r1,3b     /* aos count, loop back */
1210 6:      movw    $t.vec,r0
1211         bsbw    ublock          /* Make the vector */
1212         popr    $bit2+bit3
1213         rsb
1214
1215 /* return argument vector for process.  numarg and argbeg set up by
1216    startup code; returns false if no arguments */
1217 gargv:  movl    numarg,r1
1218          jleq   gargn           /* No arguments */
1219         pushr   $bit2+bit3
1220         movl    argbeg,r0
1221 3:      clrl    r3
1222         movl    (r0),r2         /* point to a string */
1223 1:      tstb    (r2)
1224          beql   2f
1225         incl    r2
1226         aobleq  $1024,r3,1b
1227 2:      movw    $t.str,(r13)+
1228         movw    r3,(r13)+
1229         movl    (r0),(r13)+     /* Push the string */
1230         addl2   $4,r0
1231         sobgtr  r1,3b
1232         movl    numarg,r1
1233         movw    $t.vec,r0
1234         bsbw    ublock
1235         popr    $bit2+bit3
1236         rsb
1237 gargn:  movw    $t.false,r0
1238         clrl    r1
1239         rsb
1240
1241 ghomst: movw    $homlen,r0
1242         ashl    $16,r0,r0
1243         movw    $t.str,r0
1244         moval   homstr,r1
1245         rsb
1246
1247 /* sets - codes as in gets above
1248 * call:
1249 *       r0/ type (not checked)
1250 *       r1/ value to store
1251 *       r3/ code
1252 * returns:
1253 *       r0/ type
1254 *       r1/ value */
1255
1256 isets:  caseb   r3,$1,$16       /* dispatch on type */
1257 setab:  .word   seter-setab     /* args - error */
1258         .word   setobl-setab
1259         .word   setbnd-setab    /* binding - error */
1260         .word   secall-setab
1261         .word   sncall-setab
1262         .word   suwatm-setab
1263         .word   spgptr-setab
1264         .word   setmnf-setab
1265         .word   sicall-setab
1266         .word   smappe-setab
1267         .word   senvir-setab    /* a no-op */
1268         .word   senvir-setab    /* for argv--does nothing */
1269         .word   senvir-setab    /* for homstr--does nothing */
1270         .word   srunin-setab
1271         .word   stbind-setab
1272         .word   stingc-setab
1273 seter:  bsbw    comper          /* should never reach this */
1274
1275 stingc: movl    r1,ingc
1276         rsb
1277
1278 stbind: movq    r0,tbindt
1279         rsb
1280
1281 srunin: movl    $t.fix,(r13)+   /* push relative PC */
1282         subl3   (sp)+,im.code+ov(r11),(r13)+
1283         movl    $t.fix,(r13)+
1284         movl    r1,(r13)+
1285         bsbw    kerint          /* handle pending interrupts */
1286         movl    -(r13),runint   /* set up flag */
1287         subl2   $4,r13
1288         subl3   -(r13),im.code+ov(r11),-(sp)    /* restore PC */
1289         subl2   $4,r13
1290         rsb
1291
1292 setobl: movq    r0,topobl
1293         rsb
1294 setbnd: movl    r1,spsto
1295         rsb
1296 secall: movl    r1,ecall
1297         rsb
1298 sicall: movl    r1,icall
1299         rsb
1300 sncall: movl    r1,ncall
1301         rsb
1302 suwatm: movl    r1,uwatm
1303         rsb
1304 spgptr: movq    r0,pagptr
1305         rsb
1306 setmnf: movl    r1,minf
1307         rsb
1308 smappe: movl    r1,mapper
1309 senvir: rsb
1310
1311 /* incall - internal call
1312 * call: bsb     ncall
1313 *       jmp     msubr
1314 * return:
1315 *       frame set up, with
1316 *       return address 3 bytes after bsb (after brw)
1317 *       new frame has same MS, otherwise new    */
1318
1319 incall: subl3   (sp),im.code+ov(r11),r6         /* get return address
1320                                                     and relativize */
1321         subl2   $3,r6           /* make frame return after jmp */
1322         bsbw    iframe          /* push an empty frame */
1323         movl    r12,r3          /* save old fr in case we change it */
1324         bsbw    ungfrm          /* chase last unglued frame */
1325         movl    spsto,r0        /* check for relativize needed */
1326          beql   1f
1327         subl2   r12,r0
1328 1:      movw    r0,fr.sp(r12)   /* save current SP */
1329         movl    r6,fr.pc(r12)   /* save return PC */
1330         movl    fr.msa(r12),r0  /* get msubr pointer for new guy */
1331                                 /* change to NEW frame */
1332         movl    r13,r12
1333         movl    r3,fr.fra(r12)  /* and previous frame    */
1334         incl    framid          /* bump frame id */
1335         movw    framid,fr.id(r12) /* and store it in frame */
1336         movl    r0,fr.msa(r12)  /* for incall, msa is carried over */
1337         rsb
1338
1339
1340 /* iret - MSUBR return code */
1341
1342
1343 iret:   bsbw    frmfix          /* unravel the frame */
1344 1:      subl3   r7,im.code+ov(r11),r7   /* unrelativize PC */
1345         jmp     (r7)            /* PC returned here */
1346
1347
1348 /* frmfix - unravel frame, leaving return PC in r7 */
1349
1350 frmfix: tstb    fr.ffb(r12)     /* is it a glued frame? */
1351          blss   fixrel          /* no, fix real frame */
1352                                 /* GLUED FRAME */
1353         subl3   $(gfr.len<1),r12,r13    /* < flush glued frame from tp */
1354         mnegl   gfr.pc(r12),r7  /* get return PC out, negated */
1355         movl    gfr.fra(r12),r12 /* restore old FR */
1356         rsb
1357
1358                                 /* REAL FRAME */
1359 fixrel: subl3   $fr.len*2,r12,r13 /* < flushing frame */
1360 9:      movl    fr.fra(r12),r12 /* restore FR */
1361         movl    r12,r3          /* save FR in case we change it */
1362         bsbw    ungfrm          /* back up to unglued frame */
1363         pushl   r12             /* save unwound frame */
1364         cvtwl   fr.sp(r12),r8   /* get saved SP */
1365          beql   1f
1366         addl2   r12,r8          /* unrelativize */
1367 1:      cmpl    spsto,r8        /* need to unbind? */
1368          jeql   2f              /* not if current binding same as this frame */
1369           movl  r3,r12          /* get the right frame back */
1370           bsbw  iunbnx          /*  unbind */
1371 2:      movl    (sp)+,r12       /* get the unglued frame back */
1372         movl    fr.msa(r12),r2  /* find the MSUBR */
1373         movl    ms.im+ov(r2),r2 /*  IMSUBR atom */
1374         movl    a.gbind(r2),r2  /* its GBIND */
1375         movl    ov+gb.obj(r2),r11 /* its IMSUBR to MS */
1376         movl    fr.pc(r12),r7   /* return PC in known place */
1377          jleq   1f
1378         subl3   r7,im.code+ov(r11),r7
1379 1:      movl    r3,r12          /* and restore possible changed frame */
1380 /* Do tracing here, so don't get 69 things from glued calls */
1381         tstl    mtrace          /* looking for trace? */
1382          beql   2f              /* no, skip it */
1383         decl    mdepth          /* reduce depth of nesting */
1384
1385         pushr   $bit0+bit1+bit3+bit5+bit12 /* save registers used for print */
1386         bsbw    prspac          /* print many spaces */
1387         movl    $lesst,r1       /* print a less-than at return */
1388         movl    $1,r3           /* that's just 1 character */
1389         clrl    r5              /* to tty */
1390         bsbw    print           /* print the sucker */
1391
1392         bsbw    ungfrm
1393         movl    fr.msa(r12),r1  /* point to msubr */
1394         movl    ms.name+ov(r1),r1 /* point to atom */
1395         movzwl  10(r1),r3       /* get character count */
1396         movq    8(r1),r0        /* string pointer */
1397         clrl    r5              /* channel 0 */
1398         bsbw    print           /* print MSUBR name */
1399         movl    $crlf,r1
1400         movl    $2,r3           /* 2 characters */
1401         clrl    r5              /* to terminal */
1402         bsbw    print           /* print crlf */
1403         popr    $bit0+bit1+bit3+bit5+bit12 /* restore dem registers */
1404
1405 2:      rsb
1406
1407 /* iunbind - unbind entry from external world
1408 *
1409 * call: r1/ saved SP pointing to binding
1410 *       (may mung all registers except r0-r1 pair)
1411 * return:
1412 *       (unbinding done) */
1413
1414 iunbind: movl   r1,r8           /* put SP in known place */
1415                                 /* drop through into internal routine */
1416 iunbnx: movl    spsto,r6        /* get current SP */
1417         clrl    r2              /* clear "last binding" slot */
1418 iunbnl: cmpl    r6,r8           /* are we done? */
1419          bleq   iunbnd
1420         movl    lb.atom(r6),r9  /* point to atom */
1421          jeql   un.1            /*  none */
1422         cmpl    r9,uwatm        /* unwinder? */
1423          jeql   dounwi          /*  yes - unwind */
1424
1425 unjoin: movl    lb.last(r6),a.lbind(r9) /* get last binding */
1426 un.1:   movl    r6,r2
1427         movl    lb.prev(r6),r6  /* next binding */
1428         brb     iunbnl          /* loop */
1429
1430 iunbnd: movl    r6,spsto        /* store current binding */
1431         rsb
1432 /* this used to fixup tp, but clr claims it don't have to no more */
1433
1434 dounwi: movl    lb.obj+4(r6),r7         /* get object out of binding (frame) */
1435          jeql   unjoin                  /* isn't one */
1436         movl    fr.msa(r7),r9           /* setup pointer to msubr */
1437         movl    ov+ms.im(r9),r9         /*  IMSUBR atom */
1438         movl    a.gbind(r9),r9          /* its GBIND */
1439         movl    ov+gb.obj(r9),r11       /* its IMSUBR to MS */
1440         addl3   ov+ms.im(r11),16(r6),r9 /* point to code  and offset*/
1441                 /* the offset is stored in the DECL word by the compiler */
1442         addl3   $ln.bindb,r6,r13        /* keep room for binding */
1443         cmpw    (r13),$t.frame          /* is it followed by a frame pointer */
1444          jneq   1f                      /* no */
1445         movl    4(r13),r7               /* then that's the real McCoy */
1446         addl2   $8,r13                  /* preserve it */
1447 1:      movq    r0,(r13)+       /* push r0 & r1 to save return over unwinder */
1448         movl    $(fr.len<17+t.frame),(r13)+ /* > don't ask me... */
1449         movl    r12,(r13)+
1450         movl    $(ln.bind<16+t.bind),(r13)+ /* > */
1451         movl    r8,(r13)+
1452         movl    r7,r12
1453         movl    r6,spsto
1454         jmp     0(r9)                   /* call unwinder */
1455
1456 /* here to exit from unwinder */
1457
1458 unwcnt: movl    -4(r13),r8              /* restore saved registers */
1459         movl    -12(r13),r12
1460         subl2   $16,r13                 /* fix stack */
1461         movq    -(r13),r0               /* restore real return values */
1462         movl    spsto,r6
1463         movl    r12,r3                  /* for FRMFIX */
1464         movl    uwatm,r9
1465         brw     unjoin                  /* rejoin common code */
1466
1467 /* iactiv - setup activation
1468
1469         (saves all registers)   */
1470
1471 iactiv: pushl   r0                      /* save callers r0 */
1472         subl3   im.code+ov(r11),4(sp),r0        /* relativize calling pc */
1473         pushl   r12                     /* save in case it changes */
1474         bsbw    ungfrm                  /* find real frame */
1475         movl    r0,fr.act(r12)          /* smash PC into frame */
1476         subl3   r12,r13,r0
1477         addw3   $8,r0,fr.tp(r12)                /* and TP */
1478         bisb2   $ffbit,fr.ffb(r12)      /* make sure still a full frame */
1479         movl    $fr.len<16+t.frame, (r13)+ /* push (possible glued) frame */
1480         movl    (sp)+,r12                       /* restore FR */
1481         movl    r12,(r13)+
1482         movl    (sp)+,r0                        /* and r0 */
1483         rsb
1484
1485 /* iretry - retry a frame
1486 call:
1487         r1/ frame to retry      */
1488
1489 retry:  movl    r1,r12                  /* new frame pointer */
1490         pushl   fr.msa(r12)
1491         pushl   r1                      /* save for TP computation */
1492         movw    fr.arg(r12),-(sp)               /* save some stuff */
1493         bsbw    frmfix                  /* fixup */
1494         bsbw    iframe                  /* create a frame */
1495         clrl    r0
1496         movzwl  (sp)+,r1                /* get back fr.arg count */
1497         ashl    $3,r1,r0                /* times 8 for byte count */
1498         addl3   r0,(sp)+,r13                    /* correctly */
1499         pushl   r12                     /* save in case clobbered */
1500         bsbw    ungfrm                  /* get real frame */
1501         movl    fr.pc(r12),r2           /* get PC */
1502         movl    (sp)+,r12               /* restore FR */
1503         movl    (sp)+,r4                /* get saved msubr to r4 for icret */
1504         movl    r1,r0                   /* put number of arguments in r0 */
1505         brw     icret                   /* r0 has number of args still... */
1506
1507 /* sblock - ublock for stack
1508 * call:
1509 *       r0/ type of structure
1510 *       r1/ # of frobs on stack (not same as size)
1511 * return:
1512 *       r0/ count,,type
1513 *       r1/ pointer to structure
1514 On return, the structure will be on the top of stack, with the arguments
1515 popped, and appropriate dope words surrounding it.  For the vector case,
1516 this just calls ituple.
1517 This must preserve all acs except 0 and 1.
1518
1519 Stack objects other than tuples have two identical dope words, one at the
1520 beginning and one at the end.  The dope words are in the usual form of
1521 length,,type+dopebit
1522 nexts (of the GC) presumably will see the first one and skip the whole
1523 structure; things like top need the second one.  The length field is, as
1524 usual, the number of words in the whole structure, including dope words. */
1525
1526 sblock: pushr   $bit2+bit3+bit4+bit5+bit6       /* save some acs */
1527         bicb3   $0374,r0,r2     /* isolate primtype */
1528         caseb   r2,$0,$3        /* dispatch to special code */
1529 sbd:    .word   sblb-sbd        /* bytes */
1530         .word   sbls-sbd        /* string */
1531         .word   sblu-sbd        /* uvector */
1532         .word   sblv-sbd        /* vector */
1533         bsbw    comper
1534
1535 sblv:   bsbw    ituple          /* just like tuple */
1536         movw    $t.vec,r0       /* except really a vector */
1537 sbret:  popr    $bit2+bit3+bit4+bit5+bit6       /* restore acs */
1538         rsb
1539
1540 /* for uvectors, we know that the returned structure will fit in the
1541    space used by the pushed args (unless there aren't any), since each
1542    arg takes two words on the stack and will only take one in the
1543    uvector.  This isn't true for strings and bytes */
1544 sblu:   pushl   r1              /* save count */
1545         ashl    $3,r1,r0        /* # bytes used by args */
1546         subl3   r0,r13,r0       /* point to first arg */
1547         movl    r0,r2           /* save pointer */
1548         addl2   $2,r1           /* add space for dope words */
1549         ashl    $16,r1,r1
1550         movw    $t.uvec+dope,r1 /* here's the dope word */
1551         movl    r1,(r0)+        /* stuff it out */
1552         pushl   r0              /* this will be the return pointer */
1553         movl    4(sp),r3
1554          jeql   3f              /* empty structure */
1555 2:      movl    4(r2),(r0)+     /* move an element */
1556         addl2   $8,r2
1557         sobgtr  r3,2b           /* done? */
1558 3:      movl    r1,(r0)+        /* push bottom dope word */
1559         movl    r0,r13          /* update stack pointer */
1560         movl    (sp)+,r1        /* pick up pointer */
1561         movl    (sp)+,r0
1562         ashl    $16,r0,r0
1563         movw    $t.uvec,r0
1564         brw     sbret           /* all done */
1565
1566 sblb:   movl    $t.bytes,r5     /* type word */
1567         brb     sbls1
1568 sbls:   movl    $t.str,r5
1569 sbls1:  pushl   r1              /* save count */
1570         ashl    $3,r1,r0        /* # bytes */
1571         subl3   r0,r13,r0       /* pointer to arg block */
1572         pushl   r0              /* save pointer for second pass */
1573         clrl    r2              /* count */
1574         tstl    r1
1575          jeql   4f              /* nothing to look at? */
1576 1:      bitb    $7,(r0)         /* check SAT of first arg */
1577          jneq   3f              /* structured */
1578         incl    r2              /* character, just add one */
1579 2:      addl2   $8,r0
1580         sobgtr  r1,1b
1581         brb     4f
1582 3:      addw2   2(r0),r2        /* add length of frob */
1583         brb     2b
1584 /* r2 has number of elements in new structure; 4(sp) is number of arguments;
1585    (sp) is pointer to beginning of arg block on stack.  r0 points just past
1586    end of arg block on stack.  r5 is type code */
1587 4:      addl3   $11,r2,r3
1588         bicb2   $3,r3           /* number of bytes needed */
1589         ashl    $14,r3,r4       /* number of words in LH */
1590         movw    r5,r4
1591         bisl2   $dope,r4        /* r4 is dope word */
1592         tstl    r2
1593          jeql   5f              /* empty string */
1594         addl2   (sp),r3         /* get pointer to new home for args */
1595         ashl    $3,4(sp),r0     /* number of bytes in arg block */
1596         pushr   $bit2+bit3+bit4 /* save registers */
1597         movc3   r0,*12(sp),(r3) /* move args up stack */
1598         movl    r1,r13          /* update tp */
1599         popr    $bit2+bit3+bit4 /* restore registers */
1600 5:      movl    (sp),r1
1601         movl    r4,(r1)+        /* first dope word */
1602         movl    r1,(sp)         /* pointer to new structure */
1603         tstl    r2
1604          jeql   8f              /* empty string, so nothing to copy */
1605 /* r3 is pointer to arg block, 4(sp) is number of args, r1 is pointer to
1606    structure, r4 is dope word */
1607         movl    4(sp),r5        /* get number of args back */
1608 6:      bitb    $7,(r3)         /* see if arg is structured */
1609          jneq   8f              /* yes */
1610         movb    4(r3),(r1)+     /* no, just copy a byte */
1611 7:      addl2   $8,r3           /* update arg pointer */
1612         sobgtr  r5,6b           /* done? */
1613         bicl3   $-4,r2,r3       /* get number of bytes mod 4 */
1614          jeql   1f              /* even, no padding needed */
1615         subl2   $4,r3
1616 2:      clrb    (r1)+           /* padding byte */
1617         aoblss  $0,r3,2b
1618 1:      movl    r4,(r1)+        /* stuff out dope word */
1619         movl    r1,r13          /* update tp */
1620         movl    (sp)+,r1        /* pop pointer */
1621         ashl    $16,r2,r0
1622         bicw3   $dope,r4,r0     /* make up pointer */
1623         addl2   $4,sp           /* clean up stack */
1624         brw     sbret
1625 8:      movzwl  2(r3),r0        /* get length of string to copy */
1626          jeql   7b              /* empty, so skip it */
1627         movl    4(r3),r6        /* get pointer */
1628 9:      movb    (r6)+,(r1)+     /* copy a byte */
1629         sobgtr  r0,9b           /* decrement count */
1630         brw     7b              /* done with this string */
1631
1632 /* uninitialized stack objects.  r0 is type, r1 is # of elements in
1633    returned object. */
1634
1635 usblock:
1636         pushl   r2
1637         bicb3   $0374,r0,r2     /* isolate primtype */
1638         caseb   r2,$0,$3        /* dispatch */
1639 usbd:   .word   usblb-usbd
1640         .word   usbls-usbd
1641         .word   usblu-usbd
1642         .word   usblv-usbd
1643
1644 usblb:  movl    $t.bytes,r0     /* type */
1645         brb     usbls1
1646 usbls:  movl    $t.str,r0
1647 usbls1: addl3   $3,r1,r2
1648         bicb2   $3,r2           /* number of bytes, exclusive of dope words */
1649 usblg:  pushl   r3              /* protect previous contents */
1650         addl3   $8,r2,r3        /* allow for dope words */
1651         ashl    $14,r3,r3       /* number of words in LH */
1652         movw    r0,r3
1653         bisl2   $dope,r3        /* turn on dope bit */
1654         movl    r3,(r13)+       /* push first dope word */
1655         pushl   r13             /* pointer */
1656         addl2   r2,r13
1657         tstl    r2
1658          jeql   1f              /* don't clobber if empty structure */
1659         clrl    -4(r13)         /* zero last word, so topus can work */
1660 1:      movl    r3,(r13)+       /* second dope word */
1661         ashl    $16,r1,r1
1662         movw    r0,r1
1663         movl    r1,r0           /* make type word */
1664         movl    (sp)+,r1        /* restore pointer */
1665         movl    (sp)+,r3        /* restore saved acs */
1666         movl    (sp)+,r2
1667         rsb
1668
1669 usblu:  movl    $t.uvec,r0
1670         ashl    $2,r1,r2        /* number of bytes needed */
1671         brw     usblg           /* go build it */
1672
1673 usblv:  ashl    $16,r1,r2
1674         movw    $t.vec,r2       /* type word */
1675         pushl   r1              /* save length */
1676         movl    r2,r0
1677         movl    r13,r1
1678         pushr   $bit3+bit4+bit5
1679         bsbw    vecclr          /* zero the vector */
1680         ashl    $3,12(sp),r2    /* get number of bytes */
1681         addl2   r1,r2           /* point to dope words */
1682         addl3   $1,12(sp),r3
1683         ashl    $17,r3,r3
1684         movw    $t.vec+dope,r3
1685         movl    r3,(r2)
1686         popr    $bit3+bit4+bit5 /* first dope word */
1687         addl2   $4,sp
1688         clrl    4(r2)
1689         moval   8(r2),r13       /* update tp pointer */
1690         movl    (sp)+,r2
1691         rsb
1692
1693 /* ituple
1694 * call:
1695 *       r1/ size of tuple
1696 * return:
1697 *       r0/ count,,type
1698 *       r1/ pointer to tuple    */
1699
1700 ituple: pushl   r1
1701         ashl    $3,r1,r0        /* get byte count of tuple into r0 */
1702         subl3   r0,r13,r1       /* point to tuple */
1703         addl2   $8,r0
1704         ashl    $14,r0,r0       /* dope word has total # words */
1705         movw    $t.tuple+dope,r0 /* make it a doped tuple for stack */
1706         movl    r0,(r13)+       /* push on TP stack */
1707         clrl    (r13)+          /* dope words up */
1708         movl    (sp)+,r0
1709         ashl    $16,r0,r0
1710         movw    $t.tuple,r0
1711         rsb                     /* and return */
1712
1713 /* irtuple - return a tuple to a frame
1714 *  mretur  - same thing for special multi-return case
1715 * call:
1716 *       r1/ number of args
1717 *       r2/ frame
1718 *       r7/ still has return address from someplace
1719 * return:
1720 *       r0/ cnt,, type (=tuple)
1721 *       r1/ pointer to tuple            */
1722
1723 mretur: pushl   $1              /* flag saying this mreturn */
1724         brb     mret2
1725 irtuple:
1726         clrl    -(sp)           /* flag saying rtuple */
1727 mret2:  tstl    r2              /* get target frame */
1728          jneq   1f              /* is frame arg 0?*/
1729         movl    r12,r2          /* use current frame */
1730 1:      movl    r2,r3           /* save orig frame */
1731 2:      tstb    fr.ffb(r2)      /* is it a glued frame? */
1732          jgeq   grtupl          /* yes, special handling */
1733         tstl    (sp)            /* jump if rtuple */
1734          jeql   mret3
1735         cmpl    fr.head(r2),$fr.len<16+dope+t.sframe
1736          jeql   mret3           /* if this is a seg call, go return */
1737         movl    fr.fra(r2),r2
1738 6:      tstb    fr.ffb(r2)
1739          blss   5f
1740         movl    fr.act(r2),r2
1741         brb     6b
1742
1743 5:      movl    fr.msa(r2),r4   /* point to msubr */
1744         movl    ms.im+ov(r4),r4 /* IMSUBR atom */
1745         movl    a.gbind(r4),r4  /* GBIND */
1746         movl    gb.obj+ov(r4),r4        /* IMSUBR */
1747         movl    fr.pc(r2),r7    /* get this frames ret PC */
1748         subl3   r7,im.code+ov(r4),r7 /* get PC back */
1749         cmpw    $jmpa,(r7)      /* next ins absolute jump? */
1750          jneq   4f
1751         cmpl    $8,2(r7)        /* to a return */
1752          jneq   4f              /* nope, just return first value */
1753         movl    fr.fra(r2),r2   /* step back a frame */
1754         brb     2b              /* and try this guy */
1755
1756 /* here to do a comperr that eventually call interpreters MRETURN */
1757
1758 4:      ashl    $3,r1,r4
1759         subl3   r4,r13,r4       /* r4 now points to 1st elemet to return */
1760         bsbw    iframe          /* build a frame */
1761
1762         movl    $ln.frame<16+t.frame,(r13)+     /* pass the frame */
1763         movl    r2,(r13)+
1764
1765         movl    r1,r0
1766         jeql    1f              /* if no args, go */
1767
1768 2:      movq    (r4)+,(r13)+
1769         sobgtr  r1,2b
1770
1771 1:      addl2   $1,r0           /* one more arg */
1772         movl    ecall,r1
1773         bsbw    mcallz          /* call it */
1774         brw     comper
1775
1776 mret3:  pushl   r1              /* save args */
1777         pushl   r13             /* and stack top */
1778         movl    r2,r12          /* now make it be current frame */
1779         bsbw    frmfix          /* fix frame */
1780         subl3   r7,im.code+ov(r11),r7
1781         movl    (sp)+,r8        /* restore stack top to r8 */
1782         movl    r13,r1          /* will be tuple pointer */
1783         movl    (sp)+,r0        /* and number of args */
1784         ashl    $3,r0,r3        /* make byte count */
1785 5:      tstl    r0              /* see if no args */
1786          jeql   1f              /* none? */
1787         subl2   r3,r8           /* make room for tuple */
1788 2:      movq    (r8)+,(r13)+    /* push stuff */
1789         sobgtr  r0,2b           /* and iterate */
1790 1:      tstl    (sp)+
1791          jneq   2f
1792         ashl    $13,r3,r0       /* shift count to left half */
1793         movw    $t.tuple,r0     /* bash type code in */
1794         jmp     (r7)            /* go to return address */
1795
1796 2:      ashl    $-3,r3,r1       /* num elements to r1 */
1797         movl    $t.fix,r0
1798         jmp     3(r7)
1799
1800 /* here to rtuple/mreturn from a glued frame */
1801 grtupl: subl3   $(gfr.len<1),r2,r3      /* < flush glued frame from tp */
1802         movw    gfr.typ(r2),r5          /* type of frame */
1803         addl3   gfr.pc(r2),im.code+ov(r11),r7           /* and un relativize */
1804         movl    gfr.fra(r2),r12         /* restore old FR */
1805         ashl    $3,r1,r0                /* # bytes to r0 */
1806         subl3   r0,r13,r0               /* point to first element */
1807         movl    r3,r4                   /* copy of base */
1808         movl    (sp)+,r6                /* rtuple or mreturn */
1809          jeql   igrtp3                  /* its rtuple, don't fudge around */
1810         cmpw    $t.qsfra,r5             /* is this a seg call ? */
1811          jneq   mret2                   /* no check back */
1812 igrtp4: addl2   $3,r7                   /* skip return */
1813 igrtp3: movl    r1,r8
1814          jeql   1f
1815 2:      movq    (r0)+,(r3)+
1816         sobgtr  r8,2b                   /* and iterate */
1817         movl    r3,r13                  /* fix tp */
1818         tstl    r6                      /* rtuple or mreturn */
1819          jeql   3f
1820         movl    $t.fix,r0
1821         jmp     (r7)
1822 3:      ashl    $16,r1,r0
1823         movw    $t.tuple,r0
1824         movl    r4,r1
1825         jmp     (r7)
1826
1827 /* lckint - who knows ?? */
1828
1829 kerint: tstl    ingc
1830          jeql   2f
1831         rsb
1832 2:      tstl    intflg
1833          jneq   3f
1834         rsb
1835 3:      movl    $t.word,(r13)+
1836         movl    (sp)+,(r13)+
1837         brw     rlckint
1838
1839 lckint: tstl    ingc
1840          jeql   2f
1841         rsb
1842 2:      movl    $t.fix,(r13)+
1843         subl3   (sp)+,im.code+ov(r11),(r13)+    /* save pc */
1844 rlckint: pushl  r2
1845         clrl    cgnois
1846         clrl    cgct
1847 lcklop: ffs     $0,$32,intflg,r2
1848         pushr   $bit0+bit1
1849         locc    r2,intlen,intb1
1850          jneq   3f
1851         popr    $bit0+bit1
1852         brw     noint
1853 3:      bsbw    iframe
1854         movl    $t.fix,(r13)+
1855         movzbl  intb2(r0),(r13)+
1856         popr    $bit0+bit1
1857         movl    icall,r1        /* get frob */
1858          jeql   losint
1859         movl    $1,r0
1860         ashl    r2,$1,r2
1861         bicl2   r2,intflg
1862         bsbw    mcallz
1863         tstl    intflg
1864          jneq   lcklop
1865         movl    (sp)+,r2
1866         pushl   -(r13)
1867         cmpw    -4(r13),$t.fix  /* maybe relativize return pC*/
1868          bneq   1f
1869         subl3   (sp),im.code+ov(r11),(sp)
1870 1:      subl2   $4,r13
1871         rsb
1872 noint:  ashl    r2,$1,r2
1873         bicl2   r2,intflg
1874          jneq   lcklop
1875         movl    (sp)+,r2
1876         pushl   -(r13)
1877         cmpw    -4(r13),$t.fix
1878          bneq   2f
1879         subl3   (sp),im.code+ov(r11),(sp)
1880 2:      subl2   $4,r13
1881         rsb                     /* return */
1882
1883 /* iagain
1884 * call:
1885 *       r1/ frame pointer
1886 * return:
1887                                 */
1888
1889 iagain: cmpl    r1,r12          /* same as current frame? */
1890          jeql   again1          /* yes, skip unbinding */
1891         movl    r1,r12          /* new frame */
1892         bsbw    ungfrm          /* unglue */
1893         movzwl  fr.tp(r12),r8   /* get stack top */
1894         addl2   r12,r8          /* unrelativize */
1895         bsbw    iunbnx          /* unbind */
1896         movl    fr.msa(r12),r2  /* find the MSUBR */
1897         movl    ov+ms.im(r2),r2 /*  IMSUBR atom */
1898         movl    a.gbind(r2),r2  /* its GBIND */
1899         movl    ov+gb.obj(r2),r11 /* its IMSUBR to MS */
1900 again1: movl    fr.act(r12),r0  /* relative PC */
1901         bicl2   $bit31,r0       /* ffb bit in case it is set */
1902         addl2   ov+im.code(r11),r0
1903         movzwl  fr.tp(r12),r13  /* restore saved Tp */
1904         addl2   r12,r13
1905         movl    -4(r13),r12     /* pop the possible glued frame */
1906         jmp     (r0)            /* jump into code */
1907
1908 /* newtype - create a new type code
1909 * call:
1910 *       r1/ arg
1911 * return:
1912 *       r1/ new type code       */
1913
1914 newtype: movl   type_count,r2   /* get current type count */
1915         incl    type_count      /* bump it */
1916         ashl    $6,r2,r2        /* put it into position */
1917         bicl2   $0xFFFFFFC0,r1  /* isolate primtype */
1918         bisl2   r2,r1           /* bash it in */
1919         rsb
1920
1921 /* typewc - return type code of type word
1922 * call: r1/ type-w
1923 * return: r1/ type-c
1924 */
1925 typewc: bicl2   $0xFFFF0000,r1  /* kill any length info */
1926         movl    $t.typc,r0
1927         rsb
1928
1929 /* typew - return type word
1930 * call: r0/ type-c of frob; r1/ type-c of primtype
1931 * return: r0, r1 type-w, value
1932 */
1933 typew:  cmpzv   $0,$3,r1,$pt.rec        /* is primtype a record? */
1934          jneq   1f
1935         ashl    $-3,r1,r1               /* get offset into table */
1936         movl    rectbl+4(r1),r1         /* get primtype's entry */
1937         movl    (r1),r1                 /* pick up length */
1938         movw    r0,r1                   /* stuff type code in rh */
1939         movl    $t.typw,r0
1940         rsb
1941 1:      movl    r0,r1                   /* Otherwise, just type-c */
1942         movl    $t.typw,r0              /* with a different type word */
1943         rsb
1944
1945 /********************************************************
1946 *                                                       *
1947 *                                                       *
1948 *               Storage Allocators                      *
1949 *                                                       *
1950 *                                                       *
1951 ********************************************************/
1952
1953 /* blist - build list
1954 * call:
1955 *       r1/ number of elements
1956 *       (tp) elements have been pushed on stack
1957 * return:
1958 *       r1/ pointer to list     */
1959
1960 blist:  subl2   im.code+ov(r11),(sp)
1961         pushl   r1              /* save element count */
1962         jeql    2f              /* if none, done */
1963
1964         clrl    r3              /* list to cons to */
1965 1:      movl    -(r13),r1       /* pop an element */
1966         movl    -(r13),r0       /* from TP stack */
1967         bsbw    cons            /* cons it to list */
1968         movl    r1,r3           /* re-cons to same list */
1969         sobgtr  (sp),1b         /* and count down elements */
1970
1971 2:      movw    $t.list,r0
1972         addl2   $4,sp           /* discard element count on stack */
1973         addl2   im.code+ov(r11),(sp)
1974         rsb
1975
1976 /* bvector */
1977
1978 bvecto: halt                    /* not implemented */
1979
1980 /* birec - build record or string (zeroed)
1981 * call:
1982 *       r1/ type
1983 *       r3/ # words
1984 *       r5/ # elements
1985 * return:
1986 *       r0/ type
1987 *       r1/ pointer             */
1988
1989 birec:  subl2   im.code+ov(r11),(sp)    /* relativize pc in case gc */
1990         bsbb    birecr                  /* internal entry */
1991         addl2   im.code+ov(r11),(sp)
1992         rsb
1993
1994 birecr: movl    r1,r8           /* save type code */
1995         movl    r3,r0           /* so we can setup arg to block */
1996         ashl    $2,r0,r7        /* make a pointer past allocated words */
1997         addl2   $2,r0           /* allocate n + 2 for dope words */
1998         bsbw    iblock          /* allocate storage (return in r6) */
1999         addl2   r6,r7           /* r7 now points to dope */
2000         movw    r0,2(r7)        /* block size in lh of dope word */
2001         movw    r8,(r7)         /* type in right half */
2002         bisw2   $dope,(r7)      /* with dope turned on */
2003         movl    r6,r1           /* put pointer to block in r1 for return */
2004         rotl    $16,r5,r0       /* count of elements in lh of r0 */
2005         movw    r8,r0           /* type in right half */
2006         rsb
2007
2008 /* uublock - allocate an unitialized user object (string, vector, uvector)
2009    called like ublock, except nothing on stack */
2010
2011 uublock:
2012         subl2   im.code+ov(r11),(sp)
2013         bicb3   $0374,r0,r2     /* primtype */
2014         movl    r1,r9           /* save length */
2015         caseb   r2,$0,$3
2016 uubd:   .word   uublb-uubd      /* bytes */
2017         .word   uubls-uubd
2018         .word   uublu-uubd
2019         .word   uublv-uubd
2020         bsbw    comper
2021
2022 uublb:  movl    $t.bytes,r4
2023         brb     uubls1
2024 uubls:  movl    $t.str,r4
2025 uubls1: movl    r1,r5           /* # elements */
2026         movl    r4,r1           /* type */
2027         addl3   r5,$3,r3        /* round up to next word */
2028         ashl    $-2,r3,r3
2029         bsbw    birecr          /* call record-builder */
2030 uubret: addl2   im.code+ov(r11),(sp)
2031         rsb
2032
2033 uublu:  movl    r1,r5           /* # elements */
2034         movl    r1,r3           /* # words */
2035         movl    $t.uvec,r1      /* type */
2036         bsbw    birecr          /* do it */
2037         brb     uubret          /* return */
2038
2039 /* vector has to be zeroed before return, to keep GC happy */
2040 uublv:  movl    r1,r5
2041         ashl    $1,r1,r3        /* # words */
2042         movl    $t.vec,r1
2043         bsbw    birecr
2044         bsbb    vecclr          /* clear the vector */
2045         brb     uubret
2046
2047 /* clear a vector.  pointer is r0,r1; all other acs go away */
2048 vecclr: pushr   $bit0+bit1      /* save pointer */
2049         ashl    $-13,r0,r0      /* get # of bytes */
2050         movc5   $0,(r1),$0,r0,(r1)      /* zero the block */
2051         popr    $bit0+bit1      /* restore pointer */
2052         rsb
2053
2054 /* ublock - allocate a user object (string, vector, uvector)
2055 * call:
2056 *       r0/ type
2057 *       r1/ length
2058 *       (TP) elements are on stack
2059 * return:
2060 *       r0/ type
2061 *       r1/ pointer to object
2062 *       (stack popped)          */
2063
2064
2065 ublock: subl2   im.code+ov(r11),(sp)
2066         bicb3   $0374,r0,r2     /* isolate primtype */
2067         mnegl   r1,r7           /* negate count and copy to r7 */
2068         ashl    $3,r7,r7        /* double it and make byte count */
2069         addl2   r13,r7          /* r7 now points to first element */
2070         movl    r7,r9           /* save for restoring Tp */
2071         caseb   r2,$0,$3        /* dispatch on type */
2072 ubd:    .word   ublb-ubd        /* byte string (same as string) */
2073         .word   ubls-ubd        /* string */
2074         .word   ublu-ubd        /* uvector */
2075         .word   ublv-ubd        /* vector */
2076         bsbw    comper          /* foo */
2077
2078 ublb:   movl    $t.bytes,r5
2079         brb     ubls1
2080
2081 /* string */
2082
2083 ubls:   movl    $t.str,r5       /* type */
2084 ubls1:  clrl    r0
2085         pushl   r1              /* save # frobs on stack */
2086         tstl    r1
2087         jeql    4f              /* empty string */
2088 1:      bitb    $3,(r7)
2089         jneq    3f
2090         incl    r0
2091 2:      addl2   $8,r7
2092         sobgtr  r1,1b
2093         brb     4f
2094 3:      addw2   2(r7),r0
2095         brb     2b
2096 4:      movl    r0,r10          /* copy count for return */
2097         addl2   $11,r0          /* dope words, and round up to words */
2098         ashl    $-2,r0,r0       /* divide by 4 for words */
2099         bsbw    iblock          /* allocate that many words */
2100         movl    r6,r8
2101         movl    (sp)+,r1        /* get # elts on stack back */
2102         jeql    ublsdn          /* test for 0-length string */
2103         movl    r9,r7
2104 1:      bitb    $3,(r7)
2105         jneq    3f
2106         movb    4(r7),(r8)+     /* dump a byte */
2107 2:      addl2   $8,r7           /* next stack element */
2108         sobgtr  r1,1b           /* iterate for all chars in string */
2109         brb     ublsdn
2110 3:      movzwl  2(r7),r2
2111          jeql   2b
2112         movl    4(r7),r3
2113 4:      movb    (r3)+,(r8)+
2114         sobgtr  r2,4b
2115         brb     2b
2116 ublsdn: ashl    $16,r0,r4       /* copy number of words to left half */
2117         movw    r5,r4           /* put right type in dope word */
2118         bisw2   $dope,r4
2119         addl2   $3,r8           /* put it on a longword boundary */
2120         bicl3   $3,r8,r0        /* by clearing low order bits */
2121         movl    r4,(r0)         /* throw dopeword on stack */
2122         movl    r6,r1           /* pointer to block to return */
2123         brb     ubret           /* uniform place to return from */
2124
2125
2126 /* uvector creation */
2127 ublu:   movl    r1,r0           /* copy count */
2128         addl2   $2,r0           /* dope words allocation */
2129         movl    r0,r4           /* arg for iblock */
2130         bsbw    iblock          /* allocate storage */
2131
2132         movl    r6,r8           /* copy returned pointer */
2133         movl    r1,r10          /* copy count for return */
2134         jeql    2f              /* test for 0-length string */
2135 1:      movl    4(r7),(r8)+     /* dump a word */
2136         addl2   $8,r7           /* next stack element */
2137         sobgtr  r1,1b           /* iterate for all chars in string */
2138 2:      ashl    $16,r0,r4       /* copy number of words to left half */
2139         movw    $t.uvec+dope,r4 /* set type and dope bit */
2140         movl    r4,(r8)         /* throw dopeword on stack */
2141         movl    $t.uvec,r5      /* save type for return */
2142         movl    r6,r1           /* pointer to block to return */
2143         brb     ubret           /* uniform place to return from */
2144
2145
2146 /* vector generation */
2147
2148 ublv:   ashl    $1,r1,r1        /* number of words */
2149         movl    r1,r0           /* copy count */
2150         addl2   $2,r0           /* dope words allocation */
2151         movl    r0,r4           /* arg for iblock */
2152         bsbw    iblock          /* allocate storage */
2153
2154         movl    r6,r8           /* copy returned pointer */
2155         ashl    $-1,r1,r10      /* shift back and copy for return */
2156         jeql    2f              /* test for 0-length string */
2157 1:      movl    (r7)+,(r8)+     /* dump a word */
2158         sobgtr  r1,1b           /* iterate for all chars in string */
2159 2:      ashl    $16,r0,r4       /* copy number of words to left half */
2160         movw    $t.vec+dope,r4  /* set type and dope bit */
2161         movl    r4,(r8)         /* throw dopeword on stack */
2162         movl    $t.vec,r5       /* save type for return */
2163         movl    r6,r1           /* pointer to block to return */
2164 /* drop through to ubret */
2165
2166 ubret:  ashl    $16,r10,r0      /* copy count to left half */
2167         movw    r5,r0           /* and type to right */
2168         movl    r9,r13          /* restore TP */
2169         addl2   im.code+ov(r11),(sp)
2170         rsb
2171
2172 /* tmptbl - add a record description to table */
2173
2174 tmptbl: ashl    $3,r0,r0        /* make long index */
2175         addl2   $rectbl,r0      /* pointer to table */
2176         movq    r1,(r0)         /* store info */
2177         rsb
2178
2179 /* record - build a record
2180 * call:
2181 *       r0/ type
2182 *       r1/ number of elements
2183 *       (tp) elements on stack
2184 * return:
2185 *       (tp) popped
2186 *       (record is built)       */
2187
2188 record: subl2   im.code+ov(r11),(sp)
2189         ashl    $-3,r0,r4       /* shift and copy type */
2190         bicl2   $037777360007,r4 /* mask uninteresting bits */
2191         movl    rectbl+4(r4),r8 /* table entry to r8 */
2192         movl    r0,r4           /* get type back again */
2193         pushl   r0              /* save r0 */
2194         movzwl  2(r8),r0        /* clear left half */
2195         ashl    $-1,r0,r0       /* div by 2 for storage allocation */
2196         movl    r0,r2           /* copy */
2197         addl2   $2,r0           /* dope words */
2198         bsbw    iblock          /* allocate storage */
2199         movl    (sp)+,r0        /* restore register */
2200         pushl   r11             /* save msubr pointer (being used as a temp) */
2201         pushl   r8              /* save another one */
2202         movl    r6,r11          /* save returned pointer */
2203         ashl    $16,r2,r3       /* count to left of r3 */
2204         movw    r4,r3           /* get type to right half */
2205         pushl   r3              /* and save for return */
2206         ashl    $2,r2,r2        /* make word index */
2207         addl2   r2,r11          /* point to dopewords */
2208         addl2   $0400000,r3     /* add 2 to left half (count) */
2209         movl    r3,(r11)        /* smash dope word to stack */
2210         bisl2   $dope,(r11)     /* dope it up */
2211         movl    r1,r9           /* save number of elements for loop */
2212         ashl    $3,r1,r1        /* word count */
2213         mnegl   r1,r1           /* negate it */
2214         addl3   r13,r1,r0       /* compute stack pointer */
2215         movl    r0,r11          /* and save it here */
2216         movl    r0,r5           /* save for stack fixup */
2217         movl    $4,r1           /* element number (word # for indexing mode) */
2218
2219 /* loop to move elements:
2220 *       r6/ record
2221 *       r7/ stack
2222 *       r11/ tbl        */
2223
2224 recorl: movzwl  2(r8)[r1],r5    /* get dispatch code for put */
2225         movzwl  (r8)[r1],r10
2226 /*      ashl    $1,r5,r5         and shift it */
2227         ashl    $1,r10,r10      /* both of its */
2228         movl    (r11),r3        /* value */
2229         movl    4(r11),r4
2230         bsbw    prcas           /* call appropriate move routine */
2231         addl2   $8,r11          /* step elements */
2232         addl2   $4,r1
2233         sobgtr  r9,recorl       /* loop */
2234         movl    r0,r13          /* reset TP */
2235         movl    (sp),r0         /* restore count and type */
2236         ashl    $1,r0,r0        /* make it number of words in left half */
2237         movw    (sp),r0         /* but don't shift type as well! */
2238         addl2   $4,sp           /* fix SP */
2239         movl    (sp)+,r8                /* restore registers */
2240         movl    r6,r1
2241         movl    (sp)+,r11               /* restore MS */
2242         addl2   im.code+ov(r11),(sp)    /* unrelativize */
2243         rsb
2244
2245 /* cons - build a list element
2246 * call:
2247 *       r3/ list to cons to
2248 *       r0-r1/ value
2249 * return:
2250 *       r1/ result      */
2251
2252 icons:  subl2   im.code+ov(r11),(sp)
2253         bsbb    cons
2254         addl2   im.code+ov(r11),(sp)
2255         rsb
2256
2257 cons:   movl    czone,r9        /* a zone set up? */
2258          jeql   1f              /* no */
2259           movl  gcpoff(r9),r4   /* yes, use it */
2260           brb   consa
2261 1:       moval  rcl,r4 /* no zone */
2262 consa:  movl    rcloff(r4),r9
2263          jeql   cons1           /* get from iblock */
2264         movl    r9,r6
2265         movl    -4(r9),rcloff(r4) /* pull off chain */
2266         subl2   $4,r6           /* of free cons cells */
2267         brb     cons2
2268
2269 cons1:  movl    gcstopo(r4),r6
2270         addl2   $12,gcstopo(r4) /* 12 bytes in list cell */
2271         cmpl    gcstopo(r4),gcsmaxo(r4) /* GC needed? */
2272          jleq   cons2           /* no, flush */
2273 listgc: movl    r6,gcstopo(r4)  /* restore used pointer */
2274         movq    r0,(r13)+       /* push thing being consed */
2275         movl    $t.list,(r13)+  /* push list */
2276         movl    r3,(r13)+
2277         movl    $3,r0
2278         bsbw    rungc           /* garbage collect */
2279         movl    -(r13),r3       /* get list back */
2280         subl2   $4,r13          /* flush list type word */
2281         movq    -(r13),r0       /* get object back */
2282         movl    czone,r9        /* has to be a zone after GC */
2283         movl    gcpoff(r9),r4
2284         brw     consa           /* try again */
2285
2286 cons2:  movl    r3,0(r6)
2287         movq    r0,4(r6)        /* stuff object into list cell */
2288         movl    $t.list,r0      /* return type list */
2289         addl3   $4,r6,r1        /* return list */
2290         rsb
2291
2292 /* iblock - interface to storage allocation
2293 * call:
2294 *       r0/ number of words needed
2295 * return:
2296 *       r6/ pointer to block
2297 *       (saves all other registers used)        */
2298
2299 iblock: bitl    r0,$0xffff0000
2300          jeql   1f
2301         brw     comper
2302 1:      pushr   $bit0+bit1+bit2+bit3+bit4+bit7  /* save a few registers */
2303 iblokk: movl    czone,r4        /* zone setup? */
2304          beql   1f              /* not yet.. */
2305           movl  gcpoff(r4),r4   /* yes, use it */
2306           brb   2f
2307 1:      movl    $gcpar,r4
2308 2:      casel   r0,$2,$max_rcl-2        /* go to the right place */
2309 ibtab:  .word   iblokl-ibtab
2310         .word   iblokl-ibtab
2311         .word   iblokl-ibtab
2312         .word   iblokb-ibtab
2313         .word   iblokb-ibtab
2314         .word   iblokl-ibtab
2315         .word   iblokl-ibtab
2316         .word   iblokb-ibtab
2317         .word   iblokl-ibtab
2318         jmp     iblokb
2319 iblokl: moval   rclvoff(r4),r7
2320         movl    (r7)[r0],r6     /* test to see if stuff is there */
2321          jeql   iblokn          /* nope */
2322         movl    (r6),(r7)[r0]   /* splice out of chain */
2323         ashl    $2,r0,r0        /* convert to bytes */
2324         subl2   r0,r6           /* point above first word */
2325 /*      ashl    $-2,r0,r0       pushed, so don't convert back */
2326         addl2   $4,r6           /* compensate for dope words */
2327                                 /* drop through... */
2328 /* common return point */
2329
2330 iblokr: popr    $bit0+bit1+bit2+bit3+bit4+bit7  /* restore a few registers */
2331         rsb
2332
2333
2334 /* r0 has # words wanted, r4 has gc-params.  Return in r6 */
2335
2336 iblokb: movl    rclvoff(r4),r2  /* anything in rclb? */
2337          jeql   iblokn          /* no, allocate new */
2338         moval   rclvoff(r4),r6  /* previous pointer */
2339 ibbnxt: movzwl  -2(r2),r3       /* get first dope word */
2340         subl2   r0,r3           /* amount left */
2341          blss   ibblos          /* not enough */
2342          jeql   ibbeq           /* exactly right */
2343         subl2   $2,r3           /* must be 2 or more words left */
2344          bgeq   ibbne           /* ok, win but with slop overflow */
2345 ibblos: movl    r2,r6           /* copy to previous slot */
2346         movl    (r6),r2         /* get next slot */
2347         jeql    iblokn          /* no more, allocate from free */
2348         brb     ibbnxt          /* try next slot */
2349
2350 /* exact match (we should be so lucky) */
2351
2352 ibbeq:  movl    (r2),(r6)       /* splice out of chain */
2353         decl    r0              /* fudge */
2354         ashl    $2,r0,r0        /* words--> bytes */
2355         subl2   r0,r2           /* point to beginning of block */
2356
2357 ibbret: movl    r2,r6
2358         brb     iblokr          /* and go home winner */
2359
2360 /* inexact match, leave tailings */
2361
2362 ibbne:  movl    (r2),(r6)       /* splice out */
2363         addl2   $2,r3           /* compute new length of block */
2364         movw    r3,-2(r2)       /* new length of block */
2365         addl2   r0,r3
2366         pushl   r0              /* rclb expects pointer here, so save */
2367         movl    r2,r0           /* set up arg */
2368         bsbw    rclb            /* recycle the block */
2369         movl    (sp)+,r0                /* and restore reg */
2370         decl    r3
2371         ashl    $2,r3,r3
2372         subl2   r3,r2           /* point to beg of block */
2373         brb     ibbret
2374
2375 /* no recycling */
2376
2377 iblokn: ashl    $2,r0,r0        /* turn into bytes */
2378         movl    gcstopo(r4),r6  /* return pointer */
2379         addl2   r0,gcstopo(r4)  /* bump up used marker */
2380         jvs     iblogc          /* if pointing into p2, need GC */
2381 /*      ashl    $-2,r0,r0       no need to convert back, iblokr pops it */
2382         cmpl    gcstopo(r4),gcsmaxo(r4) /* need to run GC? */
2383          jleq   iblokr          /* no, return */
2384 /*      brb     iblog1          need to convert length to words here */
2385 iblogc: ashl    $-2,r0,r0
2386 iblog1: movl    r6,gcstopo(r4)  /* restore used marker--not used yet */
2387         pushr   $bit1+bit5+bit8+bit9+bit10
2388         bsbb    rungc
2389         popr    $bit1+bit5+bit8+bit9+bit10
2390         brw     iblokk
2391
2392 /* rung - run users GC */
2393
2394 rungc:  pushl   r0
2395         movl    czone,r1        /* must have a zone */
2396          jeql   die
2397         bsbw    iframe
2398         movl    $t.fix,(r13)+
2399         movl    r0,(r13)+
2400         movl    $1,r0
2401         movl    gcfoff(r1),r1   /* pointer to gc function */
2402         bsbw    mcallz
2403         movl    (sp)+,r0
2404         rsb
2405
2406 /* EPA */
2407
2408 /* recycle a list cell (in r0, r1) */
2409 rell:   pushl   r0
2410         movl    czone,r0
2411          jneq   1f
2412         moval   -gcpoff+rcl,r0
2413 1:      movl    gcpoff(r0),r0   /* gc-params */
2414         movl    rcloff(r0),-4(r1)       /* cdr pointer of new cell */
2415         clrq    (r1)            /* car pointer of new cell */
2416         movl    r1,rcloff(r0)
2417         movl    (sp)+,r0        /* don't step on any acs */
2418         rsb
2419
2420 /* recycle a record, in r0, r1 */
2421 relr:   movq    r0,-(sp)        /* save acs */
2422         ashl    $-16,r0,r0      /* # halfwords in record */
2423         movaw   4(r1)[r0],r0    /* point to first dope word */
2424         bsbw    rclb            /* stuff it on the chain */
2425         movq    (sp)+,r0
2426         rsb
2427
2428 relu:   movq    r0,-(sp)
2429         bicb2   $0x0F8,r0       /* get primtype */
2430         caseb   r0,$4,$3        /* off we go */
2431 relutb: .word   reluby-relutb   /* bytes */
2432         .word   reluby-relutb   /* string */
2433         .word   reluuv-relutb   /* uv */
2434         .word   reluvc-relutb   /* vector */
2435
2436 reluby: movzwl  2(sp),r0        /* get # bytes */
2437         addl2   $3,r0
2438         ashl    $-2,r0,r0       /* # longwords */
2439         jmp     reluc
2440
2441 reluuv: movzwl  2(sp),r0
2442         jmp     reluc
2443
2444 reluvc: movzwl  2(sp),r0
2445         ashl    $1,r0,r0
2446 reluc:  moval   4(r1)[r0],r0    /* point to second dope word */
2447         bsbb    rclb            /* go do it */
2448         movq    (sp)+,r0
2449         rsb
2450
2451 /* call with pointer to second dope word of structure in r0 */
2452 rclb:   movzwl  -2(r0),r1       /* block length */
2453         movw    $t.uvec+dope,-4(r0)     /* make sure a uv so msgc wins */
2454         subl2   $2,r1           /* # data words */
2455          jleq   1f              /* nothing to zero */
2456         pushr   $bit0+bit1+bit2+bit3+bit4+bit5
2457         ashl    $2,r1,r1        /* # of bytes */
2458         subl2   r1,r0           /* points to 2nd word in block */
2459         movc5   $0,(r0),$0,r1,-4(r0)    /* zero the block */
2460         popr    $bit0+bit1+bit2+bit3+bit4+bit5
2461 1:      addl2   $2,r1           /* actual # words in block */
2462         pushr   $bit2+bit3+bit4+bit5
2463         movl    czone,r2
2464          jneq   2f
2465         moval   -gcpoff+rcl,r2
2466 2:      movl    gcpoff(r2),r2   /* pick up gc-params */
2467         addl2   $rclvoff,r2
2468         clrl    r3
2469         cmpw    r1,$max_rcl
2470          jgtr   3f
2471         addl2   rcltab[r1],r2   /* point at right slot */
2472         tstl    rcltab[r1]      /* are we a `long' block? */
2473          jeql   3f              /* yes */
2474         mcoml   $0,r3           /* no, set the flag */
2475 /* r0 points to 2nd dope word, r1 is block length, r2 is slot for recycle */
2476 /* r3 is -1 if short block */
2477 3:      tstl    (r2)            /* test chain for emptiness */
2478          jneq   4f              /* not an empty chain */
2479         movl    r0,(r2)
2480         clrl    (r0)
2481 rcldon: popr    $bit2+bit3+bit4+bit5
2482         rsb
2483 4:      movl    r2,r1           /* r1 is now something else */
2484
2485 /* r1 is pointer to current block of chain; r0 is pointer to block
2486 being freed.  r2 becomes pointer to next block of chain. */
2487
2488 rclbl:  movl    (r1),r2
2489          jeql   rclin1          /* at end of chain, just splice in */
2490         cmpl    r0,r2
2491          blss   rclin           /* keep chain in ascending order */
2492         movl    r2,r1
2493         jmp     rclbl
2494
2495 rclin:  tstl    r3
2496          jneq   rclin1          /* fixed-length block, just splice it */
2497         movzwl  -2(r2),r3       /* word length of next block */
2498 /*      addl2   $2,r3           already have dope words included */
2499         ashl    $2,r3,r3
2500         subl3   r3,r2,r3        /* beginning of next block */
2501         cmpl    r0,r3           /* adjacent blocks? */
2502          jeql   1f
2503 rclin1: movl    r0,(r1)         /* no, splice into chain */
2504         movl    r2,(r0)
2505         jmp     rcldon
2506 1:      addw2   -2(r0),-2(r2)    /* adjacent, just update length */
2507         clrq    -4(r0)          /* zero the dope words */
2508         jmp     rcldon
2509
2510 rcltab: .long   0
2511         .long   0
2512         .long   8       /* two-word blocks */
2513         .long   12
2514         .long   16
2515         .long   0       /* five-word */
2516         .long   0
2517         .long   28
2518         .long   32
2519         .long   0
2520         .long   40
2521
2522 /* setzon -- set current free storage zone
2523    call:
2524         r1/     new zone or 0 to return the current
2525                 if r1 is 0 and no zone, return UVECTOR of gcparams
2526 */
2527 setzon: tstl    r1              /* new one supplied? */
2528         jneq    1f              /* yes, set it up */
2529
2530         movl    czone,r1        /* is there one to return? */
2531         jeql    2f              /* no return gcparams */
2532
2533         movl    $(zlnt<16+t.zone),r0
2534         rsb
2535
2536 1:      movl    r1,czone
2537         tstl    ingc            /* were we in a GC? */
2538          jeql   3f              /* no */
2539         tstl    cgnois          /* waiting for ctrl-G? */
2540          jeql   3f              /* no */
2541         clrl    cgnois          /* clear the flag */
2542         pushr   $bit0+bit1+bit2+bit3+bit4+bit5
2543         moval   cgmsg2,r1
2544         movl    cgms2l,r3
2545         clrl    r5
2546         bsbw    print           /* print a message */
2547         popr    $bit0+bit1+bit2+bit3+bit4+bit5
2548 3:      rsb
2549
2550 2:      movl    $gcpar,r1
2551         movl    $(gclnt<16+t.uvec),r0
2552         rsb
2553
2554 /****************************************************************
2555 *                                                               *
2556 *                                                               *
2557 *                       GC Stuff                                *
2558 *                                                               *
2559 *                                                               *
2560 ****************************************************************/
2561
2562 /* swnxt -- sweep next
2563         call:   r0,r1 --> current object, and returned next object
2564         r2--> gc-params to use
2565 */
2566
2567 swnxt:  pushr   $bit2+bit3              /* save temp reg */
2568         tstl    r1              /* is this first time */
2569         bneq    1f              /* no, not first, time to sweep */
2570
2571         movl    gcstopo(r2),r1  /* start at top */
2572 1:      cmpl    gcsmino(r2),r1  /* see if done */
2573         blss    2f
2574
2575         movl    $t.fix,r0       /* return 0 */
2576         clrl    r1
2577 swret:  popr    $bit2+bit3
2578         rsb
2579
2580 2:      bicl2   $0xFFFFFFC0,r0  /* isolate primtype */
2581         cmpw    r0,$pt.list
2582         bneq    1f
2583
2584         subl2   $4,r1           /* point to start of list */
2585 1:      bitl    $dope,-8(r1)    /* dope word? */
2586          bneq   1f              /* yes, more hair */
2587         movl    $t.list,r0      /* list, say so */
2588         subl2   $8,r1
2589         brb     swret
2590
2591 1:      movzwl  -6(r1),r0       /* get dw length */
2592         ashl    $2,r0,r2        /* to bytes */
2593         subl2   $2,r0           /* fixup count */
2594         ashl    $16,r0,r0
2595         bicw3   $dope+mark_bit,-8(r1),r3        /* get type */
2596         subl2   r2,r1           /* r1 point to start */
2597         bicl3   $0xFFFFFFC0,r3,r2
2598         caseb   r2,$0,$7
2599 swtab:  .word   comper-swtab
2600         .word   comper-swtab
2601         .word   swrec-swtab
2602         .word   comper-swtab
2603         .word   swbyt-swtab
2604         .word   swbyt-swtab
2605         .word   swdone-swtab
2606         .word   swvec-swtab
2607         brw     comper
2608 swbyt:  ashl    $2,r0,r0
2609         brb     swdone
2610 swrec:  ashl    $1,r0,r0
2611         brb     swdone
2612 swvec:  ashl    $-1,r0,r0
2613 swdone: bisw2   r3,r0           /* turn on type in return word */
2614         brb     swret
2615
2616 /* nexts -- sweep stack to find things to mark
2617         call:   r1/ arg and return
2618                    if r1 --> 0 on call, return start of stack
2619                    if r1 --> 0 on return, sweep of stack done
2620 */
2621
2622 nexts:  pushl   r0              /* save extra register */
2623         tstl    r1              /* first time? */
2624         jneq    1f              /* no sweep */
2625
2626         movl    czone,r0        /* get current zone */
2627         movl    gcpoff(r0),r0   /* point gc params */
2628         movl    $max_rcl,r1
2629 2:      clrl    (r0)+
2630         sobgtr  r1,2b
2631         movl    tpstart,r1
2632         mcoml   $0,ingc         /* prevent ints for a while */
2633
2634 1:      movl    (r1),r0         /* examine last thing */
2635         bitl    $dope,r0        /* does last thing returned have dope word? */
2636          jneq   7f              /* nope, no need to adjust */
2637         addl2   $8,r1           /* move to next guy */
2638         brb     4f              /* and check him out */
2639
2640 7:      cmpw    $dope+t.tuple,r0 /* just skip tuple dope words */
2641          jeql   2f
2642         cmpw    $dope+t.vec,r0  /* in whatever form they come */
2643          jeql   2f
2644         bicw2   $0xFFFF,r0      /* isolate length */
2645         rotl    $17,r0,r0       /* position and double length */
2646         addl2   r0,r1           /* point to end */
2647 4:      movw    (r1),r0         /* get type code */
2648         bbsc    $5,r0,nxtdop    /* got a dope word */
2649         bitw    $7,r0           /* don't return words */
2650          jeql   2f
2651 nodop:  cmpw    $t.tuple,r0     /* tuple? */
2652          jeql   2f              /* marked when encountered */
2653         cmpw    $t.qfram,r0     /* quick frame */
2654          jneq   3f
2655         addl2   $gfr.len*2,r1   /* skip it */
2656         brb     4b
2657 2:      addl2   $8,r1
2658         brb     4b
2659 3:      cmpl    r13,r1          /* see if end of stack */
2660          jgeq   nextrt
2661         clrl    r1
2662 nextrt: movl    (sp)+,r0
2663 1:      rsb
2664 nxtdop: cmpw    $t.tuple,r0
2665          jeql   2b              /* skip tuple dope words */
2666         cmpw    $t.vec,r0
2667          jeql   2b
2668         cmpw    $t.qfram,r0     /* and glued frames */
2669          jneq   9f
2670         addl2   $gfr.len*2,r1
2671         brw     4b
2672 9:      cmpzv   $0,$3,r0,$pt.rec        /* other records get returned */
2673          jeql   3b
2674         movzwl  2(r1),r0                /* get word length */
2675         ashl    $2,r0,r0                /* turn into bytes */
2676         addl2   r0,r1                   /* move past this */
2677         brw     4b
2678
2679 /* get stack parameters.  Called with UV in r0/r1, returns it there. */
2680 /* parameters are:  bottom of stack, top of stack, current max top of
2681    stack, absolute max top of stack (top of data space), top of buffer
2682    space, bottom of buffer space */
2683 getstk: movq    r0,(r13)+
2684         decw    -6(r13)
2685          jlss   getskd
2686         movl    tpstart,(r1)+           /* get beginning of stack */
2687         decw    -6(r13)
2688          jlss   getskd
2689         moval   -8(r13),(r1)+           /* current top of stack */
2690         decw    -6(r13)
2691          jlss   getskd
2692         addl3   $tp_buf,tptop,(r1)+     /* max top of stack */
2693         decw    -6(r13)
2694          jlss   getskd
2695         movl    tpmax,(r1)+
2696         decw    -6(r13)
2697          jlss   getskd
2698         addl3   $pur_init,$prstart,(r1)+        /* top of buffer space */
2699         decw    -6(r13)
2700          jlss   getskd
2701         moval   prstart,(r1)+           /* bottom of buffer space */
2702 getskd: movl    -(r13),r1
2703         subl2   $4,r13
2704         rsb
2705
2706 bigstk: tstl    r1
2707          jeql   1f                      /* return current state */
2708         movl    stkok,r1
2709         movl    $1,stkok
2710         rsb
2711 1:      movl    stkok,r1
2712         rsb
2713
2714 /* move stack.  Called with relocation in r0, assumes that all pointers
2715    except within frames/lbinds or at top level on stack (tuple pointers)
2716    will be updated by subsequent GC (which
2717    had better be pretty clever). */
2718 movstk: movl    tpstart,r1              /* bottom of stack */
2719 movlop: cmpl    r1,r13
2720          jgeq   movdon
2721         bitl    $dope,(r1)              /* are we looking at a dope word? */
2722          jneq   movdop                  /* yes */
2723         cmpw    $t.qfram,(r1)
2724          jeql   movqfr
2725         bitl    $7,(r1)                 /* are we looking at a pointer? */
2726          jeql   movldn                  /* no, skip it */
2727         movl    4(r1),r2
2728         cmpl    r2,r13                  /* pointer above top of stack? */
2729          jgtr   movldn
2730         cmpl    r2,tpstart              /* below bottom? */
2731          jlss   movldn
2732         addl2   r0,4(r1)                /* update the frob */
2733 movldn: addl2   $8,r1                   /* and move on */
2734         brw     movlop
2735 movdop: bicl3   $dope,(r1),r2           /* turn off dope bit */
2736         cmpzv   $0,$3,r2,$pt.vec        /* tuples, vectors, etc. */
2737          jeql   movldn
2738         cmpzv   $0,$3,r2,$pt.rec        /* see if a record */
2739          jneq   movstr                  /* no, just random structure */
2740         cmpw    $t.bind,r2              /* lbind */
2741          jeql   movlbn
2742         addl2   $fr.len*2,r1            /* move to end of frame */
2743         addl2   r0,fr.fra(r1)           /* update frame pointer */
2744         brw     movlop
2745 movstr: ashl    $-14,r2,r2              /* get bytes in structure */
2746         addl2   r2,r1                   /* update pointer */
2747         brw     movlop                  /* and move on */
2748 movlbn: addl2   $4,r1
2749         movl    lb.prev(r1),r2
2750         cmpl    r2,r13
2751          jgtr   1f
2752         cmpl    r2,tpstart
2753          jlss   1f
2754         addl2   r0,lb.prev(r1)
2755 1:      movl    lb.last(r1),r2
2756         cmpl    r2,r13
2757          jgtr   2f
2758         cmpl    r2,tpstart
2759          jlss   2f
2760         addl2   r0,lb.last(r1)
2761 2:      addl2   $ln.bindb,r1            /* move to end */
2762         brw     movlop
2763 movqfr: addl2   $gfr.len*2,r1           /* move to end of glued frame */
2764         addl2   r0,gfr.pfr(r1)
2765         addl2   r0,gfr.fra(r1)          /* update pointers */
2766         brw     movlop
2767 movdon: addl2   r0,spsto        /* update binding chain start */
2768 /* now blt the stack */
2769 movagn:
2770 2:      addl3   r0,tptop,arg1
2771         movl    $1,argn
2772         pushl   r0
2773         pushl   ap
2774         moval   argn,ap
2775         chmk    $_break
2776         movl    (sp)+,ap        /* get memory */
2777         movl    (sp)+,r0
2778          jcs    movflt          /* frob failed */
2779         movl    tpstart,r1
2780         subl3   r1,r13,r2       /* current stack length */
2781         addl2   r0,tpstart
2782         movl    tpstart,stkbot
2783         movl    tpstart,r3
2784         addl2   r0,tptop        /* update kernel's stack pointers */
2785         movl    tptop,stkmax    /* save for compiled code to look at */
2786         addl2   r0,r13
2787         addl2   r0,r12
2788         movc3   r2,(r1),(r3)    /* blt the stack */
2789         rsb                     /* all done */
2790
2791 movflt: bsbw    nomem
2792         brw     movagn
2793
2794 nomem:  pushr   $bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit9+bit10+bit11+bit12
2795         moval   restlos,r1
2796         ashl    $16,restlol,r0
2797         mcoml   $1,r2           /* keep the loser from dying */
2798         bsbw    rfatal
2799         popr    $bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit9+bit10+bit11+bit12
2800         rsb
2801
2802 imarkr: cmpl    r1,r13          /* anything on the stack is not marked */
2803          jgtr   9f
2804         cmpl    r1,tpstart
2805          jlss   9f
2806         rsb
2807 9:      bicw2   $0xFFFF,r0
2808         rotl    $17,r0,r0       /* get length  times 2 from pntr */
2809         addl2   r0,r1           /* point to d.w. */
2810         tstl    r3              /* if unmark, jump */
2811          jeql   1f
2812         bisw2   $0x8000,(r1)    /* mark it */
2813         clrl    4(r1)
2814         cmpl    $1,r3
2815          jeql   2f              /* just mark it */
2816         movl    r3,4(r1)        /* store relocation */
2817 2:      rsb
2818 1:      bicw2   $0x8000,(r1)    /* kill bit */
2819 3:      rsb
2820
2821 imarkrq:
2822         tstl    r0              /* check type ac */
2823          jeql   3b              /* leave on zero type word */
2824         cmpl    r1,r13          /* anything on the stack is marked */
2825          jgtr   1f
2826         cmpl    r1,tpstart
2827          jgtr   4f
2828 1:      pushl   r0
2829         bicw2   $0xFFFF,r0
2830         rotl    $17,r0,r0
2831         addl2   r0,r1
2832         movl    (sp)+,r0
2833         tstb    1(r1)           /* marked? */
2834          jgeq   2f
2835         movl    4(r1),r1        /* any reloc pointer */
2836          jneq   3f
2837 4:      movl    $1,r1
2838 1:      movl    $t.fix,r0
2839 3:      rsb
2840 2:      clrl    r1
2841         brb     1b
2842
2843
2844 /****************************************************************
2845 *                                                               *
2846 *                                                               *
2847 *                       Structure manipulators                  *
2848 *                                                               *
2849 *                                                               *
2850 ****************************************************************/
2851
2852 /* nthu - nth of string/ vector/ uvector
2853 * call:
2854 *       r0/ type
2855 *       r1/ pointer
2856 *       r2/ number
2857 * return:
2858 *       r0-r1/ type-value       */
2859
2860 nthu:   bicl2   $0xFFFFFFFC,r0  /* isolate primtype */
2861         caseb   r0,$0,$3        /* dispatch on type */
2862 nutab:  .word   nthub-nutab
2863         .word   nthus-nutab
2864         .word   nthuu-nutab
2865         .word   nthuv-nutab
2866         bsbw    comper          /* any other type is fatal */
2867
2868 nthub:  addl2   r2,r1
2869         movzbl  (r1),r1
2870         movl    t.fix,r0
2871         rsb
2872
2873 nthus:  addl2   r2,r1           /* point to byte */
2874         movzbl  (r1),r1         /* get byte */
2875         movl    t.char,r0       /* type char */
2876         rsb
2877
2878 nthuu:  ashl    $2,r2,r2        /* make index */
2879         movl    (r2)[r1],r1     /* get thing */
2880         movl    t.fix,r0        /* type fix */
2881         ashl    $-2,r2,r2       /* restore number (why?) */
2882         rsb
2883
2884 nthuv:  ashl    $3,r2,r2        /* make index */
2885         movl    -8(r2)[r1],r0   /* get type */
2886         movl    -4(r2)[r1],r1   /* get thing */
2887         ashl    $-3,r2,r2       /* restore number */
2888         rsb
2889
2890 /* nthr - nth of a record
2891 * call:
2892 *       r0/ type
2893 *       r1/ pointer to record
2894 *       r2/ element number
2895 * return:
2896 *       r0,r1/ type,value       */
2897
2898 nthr:   pushr   $bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit10
2899         movzwl  r0,r0           /* clear left-half junk */
2900         ashl    $-3,r0,r0       /* and flush prim-type part */
2901         moval   rectbl+4(r0),r7 /* point to table entry */
2902         ashl    $3,r2,r2        /* index for element number */
2903         movzwl  0(r7)[r2],r3    /* get word offset */
2904         movzwl  2(r7)[r2],r4    /* code for appropriate field */
2905         ashl    $1,r3,r3        /* shift left */
2906         movl    r1,r6           /* object address */
2907         caseb   r4,$1,$12               /* dispatch */
2908 nrtab:  .word   nthrbb-nrtab            /* bool */
2909         .word   nthrer-nrtab            /* error */
2910         .word   nthrbb-nrtab            /* enumeration */
2911         .word   nthrbb-nrtab            /* subrange */
2912         .word   nthrbb-nrtab            /* subrange sbool */
2913         .word   nthrlf-nrtab            /* list/ fix */
2914         .word   nthrlf-nrtab            /* list/ fix (sbool) */
2915         .word   nthrs3-nrtab            /* struc with count */
2916         .word   nthrs3-nrtab            /* struc with count (sbool) */
2917         .word   nthrs2-nrtab            /* struc with fixed length */
2918         .word   nthrs2-nrtab            /* same (sbool) */
2919         .word   nthra-nrtab             /* any */
2920         .word   nthrhw-nrtab
2921
2922 /* out of range drops through to error */
2923
2924 nthrer: bsbw    cmperr          /* die horrible death */
2925
2926 /* boolean, etc */
2927
2928 nthrbb:
2929 /*      *** how to extract boolean? *** */
2930         bsbw    unimpl
2931
2932                                 /* drop through to common return */
2933
2934 nthrts: popr    $bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit10
2935         rsb
2936
2937
2938 /* list, fix */
2939
2940 nthrlf: movl    (r7)[r2],r0
2941         movl    (r6)[r3],r1
2942         brb     nthrts
2943
2944 /* 3 1/2 word structure */
2945
2946 nthrs3: ashl    $16,(r6)[r3],r0         /* length to left half */
2947         movw    (r7)[r2],r0             /* type to right */
2948         movl    2(r6)[r3],r1            /* value */
2949          jneq   nthrts                  /* false? */
2950 nthrfl: movl    $t.false,r0             /* yes, store falst type */
2951         brb     nthrts
2952
2953 /* structure of known length */
2954
2955 nthrs2: movl    (r7)[r2],r0             /* type */
2956         movl    (r6)[r3],r1             /* pointer */
2957          jeql   nthrfl                  /* return false? */
2958         brb     nthrts                  /* no, just return */
2959
2960 /* any case */
2961
2962 nthra:  movl    (r6)[r3],r0             /* type */
2963         movl    4(r6)[r3],r1            /* value */
2964         brb     nthrts
2965
2966 /* special type-c case */
2967
2968 nthrhw: ashl    $1,r3,r1
2969         cvtwl   (r6)[r1],r1             /* get type code or -1 */
2970          jlss   1f                      /* jump if false */
2971         movl    $t.typc,r0
2972         brb     nthrts
2973
2974 1:      clrl    r1
2975         movl    $t.false,r0
2976         brb     nthrts
2977
2978 /* restu - rest uv, v, str
2979 * call:
2980 *       r0/ type
2981 *       r1/ pointer
2982 *       r3/ number      */
2983
2984 restu:  movl    r3,(r13)+               /* save count for return */
2985         movl    r0,(r13)+               /* save cnt, type */
2986         subw2   r3,-2(r13)              /* fix count for return */
2987         bicb2   $0x0FC,r0               /* isolate 2-bit primtype */
2988         caseb   r0,$0,$3                /* dispatch */
2989 rstab:  .word   rstub-rstab     /* bytes */
2990         .word   rstus-rstab     /* string */
2991         .word   rstuu-rstab     /* uvec */
2992         .word   rstuv-rstab     /* vector */
2993
2994         bsbw    cmperr                  /* others lose */
2995
2996 /* vector */
2997
2998 rstuv:  ashl    $3,r3,r3                /* adjust count for vector thing */
2999         cmpl    r1,r13
3000          bgtr   1f                      /* above top of stack */
3001         cmpl    r1,tpstart
3002          blss   1f                      /* in pure space */
3003         movw    $t.tuple,-4(r13)        /* tuple - fix saved type */
3004         brb     rstdon                  /* and done */
3005 1:      movw    $t.vec,-4(r13)          /* vector - fix saved type */
3006         brb     rstdon                  /* and done */
3007
3008 /* uvector */
3009
3010 rstuu:  ashl    $2,r3,r3                /* adjust count for uvec thing */
3011         movw    $t.uvec,-4(r13)         /* fix saved type */
3012         brb     rstdon
3013
3014 rstub:  movw    $t.bytes,-4(r13)
3015         brb     rstdon
3016 /* string */
3017
3018 rstus:  movw    $t.str,-4(r13)          /* fix saved type */
3019                                         /* and drop through */
3020 rstdon: addl2   r3,r1                   /* fix pointer by right amount */
3021         movl    -(r13),r0               /* restore fixed type word */
3022         movl    -(r13),r3               /* and restore count */
3023         rsb
3024
3025 /* back */
3026
3027 backu:  mnegl   r3,r3                   /* its like a negative */
3028         bsbw    restu                   /* rest */
3029         mnegl   r3,r3                   /* restore r3 */
3030         rsb
3031
3032
3033 /* top things */
3034
3035 topu:   pushl   r0                      /* save type word for return */
3036         bicb2   $0x0FC,r0                       /* isolate primtype */
3037         caseb   r0,$0,$3                /* dispatch */
3038 toptab: .word   topub-toptab
3039         .word   topus-toptab    /* string */
3040         .word   topuu-toptab    /* uvec */
3041         .word   topuv-toptab    /* vector */
3042                                 /* any others drop through */
3043         bsbw    cmperr          /* oops */
3044
3045 /* bytes */
3046 topub:  pushl   r2
3047         movw    $t.bytes,r2
3048         brb     topus1
3049
3050 /* string */
3051
3052 topus:  pushl   r2
3053         movw    $t.str,r2
3054 topus1: movzwl  6(sp),r0        /* get length */
3055         addl2   r0,r1           /* point to dope word */
3056         cmpl    r1,tpstart
3057          jlss   1f
3058         cmpl    r1,tpmax
3059          jgtr   1f
3060         brw     topust          /* stack case */
3061 1:      bicl3   $0xFFFFFFFC,r1,-(sp)    /* extra chars */
3062         addl2   $3,r1           /* round to full word boundary */
3063         bicb2   $3,r1
3064 topsdn: movzwl  2(r1),r0        /* total length to r0 */
3065         subl2   $2,r0           /* not counting dope words */
3066         ashl    $2,r0,r0
3067         subl2   r0,r1           /* point to top */
3068         tstl    (sp)
3069          jeql   1f
3070         subl3   (sp),$4,(sp)
3071         subl2   (sp),r0
3072 1:      addl2   $4,sp
3073         ashl    $16,r0,r0
3074         movw    r2,r0           /* string primtype */
3075         movl    (sp)+,r2
3076         addl2   $4,sp           /* fix stack */
3077         rsb
3078 topust: bbc     $0,r1,1f        /* jump if on halfword boundary already */
3079         addl2   $1,r1           /* otherwise, move to one */
3080         movl    $1,-(sp)        /* at least one byte in last word */
3081         brb     3f
3082 1:      movl    $2,-(sp)        /* at least two bytes in last word */
3083 3:      tstw    (r1)            /* if zero, haven't hit dopeword yet */
3084          jneq   2f
3085         addl2   $2,r1           /* advance pointer to dope word */
3086         brw     topsdn
3087 2:      addl2   $2,(sp)         /* already at dopeword, 2 more in last word */
3088         bicl2   $0xFFFFFFFC,(sp)        /* but never more than 3 */
3089         brw     topsdn
3090
3091 /* uvec */
3092
3093 topuu:  movzwl  2(sp),r0        /* get length */
3094         ashl    $2,r0,r0
3095         addl2   r0,r1
3096         movzwl  2(r1),r0
3097         subl2   $2,r0           /* don't count dope words */
3098         ashl    $2,r0,r0
3099         subl2   r0,r1
3100         ashl    $14,r0,r0
3101         bisw2   $t.uvec,r0
3102         addl2   $4,sp
3103         rsb
3104
3105 /* vector */
3106
3107 topuv:  movzwl  2(sp),r0
3108         ashl    $3,r0,r0
3109         addl2   r0,r1                   /* get to dope words */
3110         movzwl  2(r1),r0                /* get count from dw */
3111 1:      subl2   $2,r0
3112         ashl    $2,r0,r0
3113         subl2   r0,r1
3114         ashl    $13,r0,r0
3115         bisw2   $t.vec,r0               /* get type */
3116         addl2   $4,sp
3117         rsb
3118
3119 /* putu - put vector, etc
3120 * call:
3121 *       r0/ type
3122 *       r1/ pointer
3123 *       r2/ element number
3124 *       r3,r4/ new value
3125 * return:
3126 *       (new value in place)            */
3127
3128 putu:   pushl   r0                      /* save type for return */
3129         bicb2   $0x0FC,r0               /* isolate primtype */
3130         caseb   r0,$0,$3                /* dispatch */
3131 putab:  .word   putus-putab
3132         .word   putus-putab
3133         .word   putuu-putab
3134         .word   putuv-putab
3135
3136         bsbw    cmperr
3137
3138 /* string case */
3139
3140 putus:  movb    r4,(r1)[r2]             /* store byte */
3141         movl    (sp)+,r0
3142         rsb
3143
3144 putuu:  movl    r4,(r1)[r2]             /* index does right thing */
3145         movl    (sp)+,r0
3146         rsb
3147
3148 putuv:  movq    r3,(r1)[r2]             /* magic index mode */
3149         movl    (sp)+,r0
3150         rsb
3151
3152 /* put record type
3153 * call:
3154 *       (args as in PUTU)       */
3155
3156 putr:
3157
3158         pushr   $bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit10
3159         movzwl  r0,r0           /* clear left-half junk */
3160         ashl    $-3,r0,r0       /* and flush prim-type part */
3161         moval   rectbl+4(r0),r8 /* point to table entry */
3162         ashl    $3,r2,r2        /* index for element number */
3163         movzwl  0(r7)[r2],r10   /* get word offset */
3164         movzwl  2(r7)[r2],r5    /* code for appropriate field */
3165         ashl    $1,r10,10       /* shift left */
3166         movl    r1,r6           /* object address */
3167         brb     1f
3168 prcas:  pushr   $bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit10
3169 1:      caseb   r5,$1,$12       /* dispatch */
3170 prtab:  .word   putrbb-prtab            /* bool */
3171         .word   putrer-prtab            /* error */
3172         .word   putrbb-prtab            /* enumeration */
3173         .word   putrbb-prtab            /* subrange */
3174         .word   putrbb-prtab            /* subrange sbool */
3175         .word   putrlf-prtab            /* list/ fix */
3176         .word   putrlf-prtab            /* list/ fix (sbool) */
3177         .word   putrs3-prtab            /* struc with count */
3178         .word   putrs3-prtab            /* struc with count (sbool) */
3179         .word   putrs2-prtab            /* struc with fixed length */
3180         .word   putrs2-prtab            /* same (sbool) */
3181         .word   putra-prtab             /* any */
3182         .word   putrhw-prtab            /* special type-c hack */
3183
3184 /* out of range drops through to error */
3185
3186 putrer: bsbw    cmperr          /* die horrible death */
3187
3188 /* boolean, etc */
3189
3190 putrbb:
3191         bsbw    unimpl
3192
3193                                 /* drop through to common return */
3194
3195 putrts: popr    $bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit10
3196         rsb
3197
3198
3199 /* list, fix */
3200
3201 putrlf: addl2   r6,r10                  /* calc address */
3202         movl    r4,(r10)                /* store value */
3203         brb     putrts
3204
3205 /* 3 1/2 word structure */
3206
3207 putrs3: addl2   r6,r10                  /* calculate address */
3208         cmpw    $t.false,r3             /* false? */
3209          jeql   putrsx                  /* naw */
3210         rotl    $16,r3,r3
3211         movw    r3,0(r10)
3212         movl    r4,2(r10)
3213         brb     putrts
3214 putrsx: clrw    (r10)
3215 putrsy: clrl    2(r10)
3216         brb     putrts
3217
3218 /* fixed length item */
3219
3220 putrs2: cmpw    $t.false,r2             /* false? */
3221         jneq    putrlf                  /* no */
3222         addl2   r6,r10
3223         brb     putrsy
3224
3225 /* any */
3226
3227 putra:  addl2   r6,r10
3228         movq    r3,(r10)
3229         brb     putrts
3230
3231 /* special type-c hack */
3232
3233 putrhw: addl2   r6,r10                  /* calculate address */
3234         cmpw    $t.false,r3
3235          jeql   1f
3236         movw    r4,0(r10)               /* store type-c */
3237         brb     putrts
3238
3239 1:      mcomw   $0,0(r10)               /* indicate false */
3240         brb     putrts
3241
3242 /* cinth */
3243
3244 cinth:  bicb2   $0x0F8,r0               /* isolate 3 bits */
3245         caseb   r0,$1,$6                /* dispatch */
3246 cintab: .word   cindbl-cintab
3247         .word   ciner-cintab
3248         .word   ciner-cintab
3249         .word   cinfby-cintab
3250         .word   cinbyt-cintab
3251         .word   cinuvc-cintab
3252         .word   cindbl-cintab
3253                                         /* errors drop through */
3254 ciner:  bsbw    cmperr
3255
3256 cindbl: movq    (r1),r0
3257         rsb
3258
3259 cinfby: movzbl  (r1),r1
3260         movl    $t.fix,r0
3261         rsb
3262
3263 cinbyt: movzbl  (r1),r1
3264         movl    $t.char,r0
3265         rsb
3266
3267 cinuvc: movl    (r1),r1
3268         movl    $t.fix,r0
3269         rsb
3270
3271 /* cirst */
3272
3273 cirst:  pushl   r9
3274         extzv   $0,$3,r0,r9             /* get rightmost 3 bits */
3275         caseb   r9,$1,$6                /* dispatch */
3276 cirtab: .word   cirlst-cirtab
3277         .word   cirer-cirtab
3278         .word   cirer-cirtab
3279         .word   cirbyt-cirtab
3280         .word   cirstr-cirtab
3281         .word   ciruvc-cirtab
3282         .word   cirvec-cirtab
3283                                 /* errors */
3284 cirer:  bsbw    cmperr
3285
3286 cirlst: movl    $t.list,r0
3287         movl    -4(r1),r1
3288         movl    (sp)+,r9
3289         rsb
3290
3291 cirbyt: incl    r1
3292         pushl   r0
3293         decw    2(sp)
3294         movl    (sp)+,r0
3295         movw     $t.bytes,r0
3296         movl    (sp)+,r9
3297         rsb
3298
3299 cirstr: incl    r1
3300         pushl   r0
3301         decw    2(sp)           /* fix count */
3302         movl    (sp)+,r0                /* is this a kludge? */
3303         movw    $t.str,r0
3304         movl    (sp)+,r9
3305         rsb
3306
3307 ciruvc: addl2   $4,r1
3308         pushl   r0
3309         decw    2(sp)
3310         movl    (sp)+,r0
3311         movw    $t.uvec,r0
3312         movl    (sp)+,r9
3313         rsb
3314
3315 cirvec: addl2   $8,r1
3316         pushl   r0
3317         decw    2(sp)
3318         movl    (sp)+,r0
3319         movw    $t.vec,r0
3320         movl    (sp)+,r9
3321         rsb
3322
3323 /* cigas */
3324
3325 cigas:  tstl    (r1)            /* test gval slot */
3326         jeql    1f              /* anything? */
3327          rsb                    /* yes, gassigned */
3328 1:      movl    $t.false,r0     /* nope, return false */
3329         clrl    r1
3330         rsb
3331
3332 /* cigvl */
3333
3334 cigvl:  movl    (r1),r1         /* get gval */
3335          jneq   1f
3336           bsbw  cmperr
3337 1:      movq    (r1),r0         /* get type and all */
3338         rsb
3339
3340 /* ciemp */
3341
3342 ciemp:  pushl   r0
3343         bicb2   $0x0F8,r0       /* isolate 3 bits */
3344         caseb   r0,$1,$6
3345 cietab: .word   cielst-cietab
3346         .word   cier-cietab
3347         .word   cier-cietab
3348         .word   cielen-cietab
3349         .word   cielen-cietab
3350         .word   cielen-cietab
3351         .word   cielen-cietab
3352
3353 cier:   bsbw    cmperr
3354
3355 cielst: movl    (sp)+,r0
3356         tstl    r1
3357          jneq   cieln1          /* non-skip return */
3358 cieln2: addl2   $3,(sp)         /* skip return (must skip a brw ins) */
3359 cieln1: rsb
3360
3361 cielen: movl    (sp)+,r0
3362         cmpl    r0,$0xFFFF
3363          jlequ  cieln2          /* skip */
3364         rsb                     /* non-skip */
3365
3366 /* cimon */
3367
3368 cimon:  pushl   r0
3369         bicb2   $0x0F8,r0       /* isolate 3 bits */
3370         caseb   r0,$0,$7
3371 cimtbl: .word   cimtru-cimtbl
3372         .word   cielst-cimtbl
3373         .word   cimtru-cimtbl
3374         .word   cimtru-cimtbl
3375         .word   cielen-cimtbl
3376         .word   cielen-cimtbl
3377         .word   cielen-cimtbl
3378         .word   cielen-cimtbl
3379
3380 cimtru: movl    (sp)+,r0
3381         brb     cieln2          /* skip return */
3382
3383
3384 /* fatal -- complain, then depart from mim */
3385
3386 efatal: movl    $1,r2           /* this one will kill the process */
3387         bsbb    rfatal
3388         jmp     comper
3389
3390 dfatal: mcoml   $1,r2
3391         bsbb    rfatal
3392         jmp     comper
3393
3394 rfatal: pushr   $bit0+bit1+bit2+bit3+bit4+bit5
3395         moval   oldtty,r1
3396         bsbw    fixtty          /* get the tty back into shape */
3397         moval   fatmsg,r1
3398         movl    fatmsl,r3
3399         clrl    r5
3400         bsbw    print
3401         movl    4(sp),r1        /* get the string pointer back */
3402         clrl    r3
3403         movw    2(sp),r3
3404         bsbw    print
3405         popr    $bit0+bit1+bit2+bit3+bit4+bit5
3406         tstl    r2
3407          jgeq   rfatex
3408         bsbw    leave
3409         moval   newtty,r1
3410         bsbw    fixtty
3411         rsb
3412 rfatex: movl    r2,arg1
3413         movl    $1,argn
3414         moval   argn,ap
3415         chmk    $_exit
3416         rsb
3417
3418 leave:  pushl   ap
3419         clrl    argn
3420         moval   argn,ap
3421         chmk    $_getpid
3422         movl    r0,arg1         /* only poke this process */
3423         movl    $17,arg2
3424         movl    $2,argn
3425         movl    $argn,ap
3426         chmk    $_kill
3427         movl    (sp)+,ap
3428         rsb
3429
3430 /* quit -- depart from mim.  Arg in r1; if >= 0, do exit */
3431
3432 quit:   pushl   r1
3433         moval   oldtty,r1
3434         bsbw    fixtty          /* fix up tty */
3435         movl    (sp)+,r1
3436          jgeq   1f              /* jump if doing exit */
3437         bsbw    leave
3438 2:      pushl   r1
3439         moval   newtty,r1
3440         bsbw    fixtty
3441         movl    (sp)+,r1
3442         rsb
3443 1:      movl    $1,argn
3444         movl    r1,arg1
3445         pushl   ap
3446         movl    $argn,ap
3447         chmk    $_exit
3448         movl    (sp)+,ap
3449         brb     2b
3450
3451 /* Call with address in r1 of block for fixing/breaking tty */
3452 fixtty: tstl    (r1)
3453          jneq   1f                      /* jump if stuff is there */
3454         rsb
3455 1:      pushl   ap
3456         clrl    arg1
3457         movl    $tiocsetn,arg2
3458         addl3   $12,r1,arg3
3459         movl    $3,argn
3460         movl    $argn,ap
3461         chmk    $_ioctl                 /* set sgttyb stuff */
3462         movl    $tioclset,arg2
3463         addl3   $8,r1,arg3
3464         movl    $3,argn
3465         movl    $argn,ap
3466         chmk    $_ioctl                 /* local modes */
3467         movl    $tiocsetc,arg2
3468         movl    r1,arg3
3469         movl    $3,argn
3470         movl    $argn,ap
3471         chmk    $_ioctl                 /* other characters */
3472         movl    $tiocsltc,arg2
3473         addl3   $18,r1,arg3
3474         chmk    $_ioctl                 /* local characters */
3475         movl    (sp)+,ap
3476         rsb
3477
3478 /* Call with state structure in r0,r1; copy stuff out of oldtty if there,
3479    else return false */
3480 gettty: tstl    oldtty
3481          jneq   1f
3482         movl    $t.false,r0
3483         clrl    r1
3484         rsb
3485 1:      pushr   $bit0+bit1+bit2+bit3+bit4+bit5
3486         movc3   $6,oldtty,*4(r1)
3487         moval   oldtty,r0
3488         movl    4(sp),r1
3489         movl    8(r0),*12(r1)
3490         movc3   $6,12(r0),*20(r1)
3491         moval   oldtty,r0
3492         movl    4(sp),r1
3493         movc3   $6,18(r0),*28(r1)
3494         popr    $bit0+bit1+bit2+bit3+bit4+bit5
3495         rsb
3496
3497 /* Call with old state in r0, new in r1.  Structure pointed to is
3498    assumed to be TTSTATE, as defined in TTY package.  0-->nothing saved. */
3499 savtty: pushl   r1
3500         moval   oldtty,r1
3501         bsbw    dottys
3502         movl    (sp)+,r0
3503         moval   newtty,r1
3504         bsbw    dottys
3505         rsb
3506
3507 dottys: tstl    r0
3508          jneq   1f
3509         clrl    (r1)
3510         rsb
3511 1:      pushr   $bit2+bit3+bit4+bit5
3512         pushl   r0
3513         pushl   r1
3514         movc3   $6,*4(r0),(r1)          /* copy chars */
3515         movl    (sp),r1
3516         movl    4(sp),r0
3517         movl    *12(r0),8(r1)
3518         movl    (sp),r1
3519         movl    4(sp),r0
3520         movc3   $6,*20(r0),12(r1)
3521         movl    (sp)+,r1
3522         movl    (sp)+,r0
3523         movc3   $6,*28(r0),18(r1)
3524         popr    $bit2+bit3+bit4+bit5
3525         rsb
3526
3527 /* save  r1 --> channel upon which to do save
3528    r2-->0 or frozen space
3529    r3-->0 or pure space */
3530
3531 isave:  movl    (sp),r0                 /* return PC */
3532         bsbb    dosave
3533         cmpw    r0,$t.false
3534          beql   isavou
3535         movl    $t.fix,r0
3536         clrl    r1
3537 isavou: rsb
3538
3539 /* This assumes that the current zone is set up and that the gc-params
3540    and areas are consistent. */
3541 dosave: movl    bindid,sbindid          /* save bindid */
3542         movl    spsto,sspsto            /* and spsto */
3543         movl    r0,(r13)+               /* push return PC */
3544         movl    r12,(r13)+              /* save frame */
3545         movl    czone,r4
3546          jeql   nozone
3547         brb     csave
3548 nozone: bsbw    comper
3549
3550 /* routine to save a zone's vital statistics on the tp stack.  Increments
3551    r0 for each area saved */
3552 zonect: movl    gcaoff(r4),r4           /* pick up area list */
3553          jeql   sloopd
3554 sloop:  movl    4(r4),r5                /* pick up area */
3555         movl    amin(r5),r3             /* maybe empty zone */
3556          jeql   sloopd
3557         movl    r3,(r13)+
3558         movl    abot(r5),(r13)+
3559         movl    amax(r5),(r13)+
3560         incl    r0
3561         movl    -4(r4),r4
3562          jneq   sloop
3563 sloopd: rsb
3564
3565 csave:  clrl    r0
3566         pushl   r4
3567         pushl   r3
3568         pushl   r2
3569         movl    (sp),r4
3570          jeql   1f
3571         bsbb    zonect                  /* save params for atom zone */
3572 1:      movl    4(sp),r4
3573          jeql   2f
3574         bsbb    zonect                  /* save params for pure zone */
3575 2:      movl    8(sp),r4
3576         bsbb    zonect                  /* main zone */
3577 /* r0 has total count of areas */
3578
3579         movl    r0,(r13)+               /* save count of areas */
3580         movl    r13,stktop              /* save TP */
3581         movl    $version,versav         /* save kernel version # */
3582         pushl   r1                      /* save channel */
3583         movl    r1,r5                   /* and pass to print */
3584         moval   savstrt,r1              /* start at savstrt */
3585         subl3   r1,$savend,r3           /* compute number of bytes */
3586         bsbw    print                   /* write kernel vars out */
3587         cmpw    r0,$t.false
3588          jeql   savlost
3589         movl    tpstart,r1              /* beginning of tp stack */
3590         subl3   r1,r13,r3               /* size of tp stack */
3591         movl    (sp),r5
3592         bsbw    print                   /* write out tp stack */
3593         cmpw    r0,$t.false
3594          jeql   savlost
3595         movl    (sp),r5                 /* channel back */
3596         movl    4(sp),r4
3597          jeql   1f
3598         bsbb    zonesv          /* save atom zone */
3599         cmpw    r0,$t.false
3600          jeql   savlost
3601 1:      movl    8(sp),r4
3602          jeql   2f
3603         bsbb    zonesv
3604         cmpw    r0,$t.false
3605          jeql   savlost
3606 2:      movl    12(sp),r4
3607         bsbb    zonesv
3608         cmpw    r0,$t.false
3609          jeql   savlost
3610         movl    (sp)+,r1
3611         bsbw    close           /* close channel */
3612         addl2   $12,sp          /* flush zones from stack */
3613 4:      mull3   $12,-(r13),r2
3614         subl2   r2,r13          /* flush areas from tp stack */
3615         subl2   $8,r13          /* other stuff on tp */
3616         rsb
3617 savlost:
3618         addl2   $16,sp          /* flush garbage from sp */
3619         brb     4b              /* clean up tp, return */
3620
3621 zonesv: movl    gcaoff(r4),r4   /* list of areas */
3622          jeql   zonesd          /* empty? */
3623 2:      movl    4(r4),r3        /* get an area */
3624         movl    amin(r3),r1     /* bottom of area */
3625          jeql   zonesd
3626         subl3   r1,abot(r3),r3  /* size of area */
3627         pushl   r4              /* save list */
3628         bsbw    print
3629         movl    (sp)+,r4        /* get list back */
3630         cmpw    r0,$t.false     /* print lost */
3631          beql   zonesd
3632         movl    -4(r4),r4       /* rest it */
3633          jneq   2b              /* loop if more */
3634 zonesd: rsb
3635         movl    (sp)+,r4        /* fix up sp */
3636
3637 /* irestor -- r1/ --> channel  */
3638
3639 irestor:
3640         bsbb    dorest
3641         tstl    r0
3642          jeql   1f
3643         movl    r0,(sp)                 /* dorest returns PC in r0 */
3644 1:      movl    $t.fix,r0
3645         movl    $1,r1
3646         rsb
3647
3648 dorest: pushl   r1                      /* save channel */
3649         clrl    p1cur
3650
3651         movl    $savstrt,r1
3652         movl    $8,r3
3653         movl    (sp),r5
3654         bsbw    read                    /* read version number */
3655         cmpl    versav,$version
3656          jneq   verlost                 /* different version, lose immediate */
3657
3658         movl    $savstrt+8,r1           /* point to first chunk */
3659         movl    $savend-savstrt-8,r3    /* kernel vars only */
3660         movl    (sp),r5                 /* channel for read */
3661         bsbw    read                    /* should now know size of stack etc */
3662         movl    sbindid,bindid          /* restore bindid */
3663         movl    sspsto,spsto            /* and spsto */
3664
3665 stkagn: pushl   ap
3666         movl    tptop,arg1
3667         movl    $1,argn
3668         moval   argn,ap
3669         chmk    $_break                 /* make sure have space for stack */
3670         movl    (sp)+,ap
3671          jcc    2f
3672         bsbw    nomem
3673         brb     stkagn
3674
3675 2:      movl    tpstart,r1              /* now read TP stack */
3676         movl    r1,stkbot               /* save in user area */
3677         movl    tptop,stkmax            /* save stack limit in user area */
3678         subl3   r1,stktop,r3            /* compute length */
3679         movl    (sp),r5
3680         bsbw    read                    /* read in TP stack */
3681
3682         movl    stktop,r13              /* get TP back */
3683         movl    -(r13),r0               /* number of areas */
3684         mull3   $12,r0,r1               /* number of bytes */
3685         subl3   r1,r13,r1               /* point to first */
3686         movl    r1,stktop               /* save, to flush this */
3687 reslop: pushr   $bit0+bit1              /* save acs */
3688         subl3   abot(r1),amax(r1),r5            /* length of area */
3689         movl    abot(r1),r3                     /* beginning of area */
3690         cmpl    r3,$0x40000000          /* part of p1? */
3691          jlss   1f
3692         subl3   r3,$0x7FFFFFFF,r1       /* yes, get distance from top of p1 */
3693         cmpl    r1,p1cur                /* already have that much? */
3694          jleq   1f
3695 vagain: movl    p1lim,limits+4          /* No, grow p1 */
3696         movl    r1,p1cur                /* say we grew it */
3697         movl    r1,limits
3698         movl    $2,argn
3699         movl    $rlimit_stack,arg1
3700         moval   limits,arg2
3701         pushl   ap
3702         moval   argn,ap
3703         chmk    $_setrlimit             /* do system call */
3704         movl    (sp)+,ap
3705          jcs    novirt                  /* jump if failed */
3706 1:      movc5   $0,(r3),$0,r5,(r3)      /* zero core */
3707         movq    (sp),r0                 /* get acs back */
3708         subl3   abot(r1),amin(r1),r3            /* get length */
3709         movl    abot(r1),r1                     /* bottom of area */
3710         movl    8(sp),r5                /* get channel back */
3711         bsbw    read
3712         popr    $bit0+bit1
3713         addl2   $12,r1
3714         decl    r0
3715          jgtr   reslop                  /* jump if more areas */
3716
3717         movl    (sp)+,r1                /* get channel back */
3718         bsbw    close
3719         movl    stktop,r13              /* get the correct tp back */
3720         movl    -(r13),r12              /* restore frame */
3721         pushl   ap
3722         movl    $rlimit_data,arg1
3723         moval   limits,arg2
3724         movl    $2,argn
3725         moval   argn,ap
3726         chmk    $_getrlimit
3727         movl    limits+4,tpmax          /* absolute top of stack */
3728         movl    $rlimit_stack,arg1
3729         moval   limits,arg2             /* store structure */
3730         movl    $2,argn
3731         moval   argn,ap
3732         chmk    $_getrlimit             /* read stack limit */
3733         subl3   limits+4,$0x80000000,r0 /* to lowest address */
3734         ashl    $byts_page_sh,r0,r0     /* to page number */
3735 /*      addl2   $1000,r0                what was this, anyway? */
3736         movl    pagpt1,r1
3737         pushl   r2
3738         movl    16(r1),r2               /* bot of GC space */
3739         movl    r0,(r1) /* new "top of P0" */
3740         movl    r0,16(r1)       /* and start of "free" space" */
3741         subl2   r2,r0           /* new-old:  neg of diff in # pages  */
3742         subl2   r0,12(r1)       /* new page count */
3743         movl    (sp)+,r2
3744         movl    (sp)+,ap
3745         movl    -(r13),r0               /* get return PC back */
3746         clrl    noboot
3747         rsb
3748
3749 novirt: bsbw    nomem
3750         brw     vagain
3751
3752 verlost:
3753         tstl    noboot                  /* see if mudsub during startup */
3754          bneq   vermud
3755         movl    (sp),arg1
3756         clrl    arg2
3757         movl    $L_SET,arg3
3758         movl    $3,argn
3759         pushl   ap
3760         moval   argn,ap
3761         chmk    $_lseek
3762         movl    (sp)+,ap
3763         brw     verlo1
3764
3765 vermud: movl    $1,argn
3766         movl    (sp),arg1
3767         pushl   ap
3768         moval   argn,ap
3769         chmk    $_close                 /* close save file */
3770         movl    (sp)+,ap
3771
3772 verlo1: movl    versav,r0
3773         clrl    r1                      /* make sure will work as quad */
3774         moval   verptr,r2
3775         movl    $1000,r3
3776 1:      ediv    r3,r0,r4,r0             /* quotient to r1, remainder to r0 */
3777          bneq   verls1
3778         divl2   $10,r3
3779         brb     1b
3780 verls1: addb3   r4,$48,(r2)+            /* deposit the byte */
3781 2:      divl2   $10,r3
3782          beql   verdon
3783         ediv    r3,r0,r4,r0
3784         addb3   r4,$48,(r2)+
3785         brb     2b
3786 verdon: clrb    (r2)
3787         moval   newker,r1
3788         movl    newkln,r3
3789         clrl    r5
3790         bsbw    print
3791         movl    argbeg,r2
3792         subl2   $4,r2
3793         tstl    noboot
3794          beql   3f
3795         movl    argone,(r2)             /* if mudsub, get org jcl */
3796         brb     4f
3797 3:      clrl    argone
3798         movb    (sp),argone
3799         moval   argone,(r2)             /* save file descriptor (funny str)*/
3800 4:      movl    r2,arg2
3801         moval   kernam,arg1
3802         movl    envbeg,arg3
3803         movl    $3,argn
3804         pushl   ap
3805         moval   argn,ap
3806         chmk    $_execve                /* try to load the right kernel */
3807         moval   savver,r1               /* failed if get here */
3808         ashl    $16,savvel,r0
3809         bsbw    efatal
3810
3811 /* allocate pages */
3812
3813 mpages: bsbw    cmperr                  /* unimplemented */
3814
3815
3816 /****************************************************************
3817 *                                                               *
3818 *                                                               *
3819 *                       Input/ Output                           *
3820 *                                                               *
3821 *                                                               *
3822 ****************************************************************/
3823
3824 /* open - open a channel to a file
3825 * call:
3826 *       r0/ type (need string count for syscall)
3827 *       r1/ string pointer to file spec
3828 *       r3/ fix (mode) 0=read, 1=write, 2=read/write
3829 * return:
3830 *       r0/ type (channel)
3831 *       r1/ file-descriptor
3832 *       (the file is positioned at byte 0)
3833 *       (all registers saved)   */
3834
3835 /* openz is just like open, except the string is already null-terminated */
3836 openz:  pushr   $bit2+bit3+bit4+bit5
3837         movl    r1,arg1                 /* dont copy file name */
3838         brw     open1
3839
3840 open:   pushr   $bit2+bit3+bit4+bit5    /* save a few scratch registers */
3841         ashl    $-16,r0,r0      /* get left halfword (count) */
3842         movc3   r0,(r1),(r13)   /* copy the string to the TP stack */
3843         clrb    (r3)            /* null terminate it */
3844         movl    r13,arg1        /* pointer to asciz string */
3845 open1:  movl    $3,argn         /* set up number of args */
3846         pushl   ap              /* save register */
3847         moval   argn,ap /* arg block */
3848         clrl    arg3
3849         movl    8(sp),arg2      /* get former r3 off stack */
3850          jneq   1f              /* jump if write--this may not work, but isn't */
3851                                 /* used anyway */
3852         chmk    $_open          /* open the file */
3853         brb     2f
3854 1:      movl    $0x1FF,arg3
3855         movl    $O_RDWR+O_CREAT,arg2
3856         chmk    $_open          /* create file */
3857 /* note potential bug of leaving file open when shouldn't if chmod fails */
3858 2:      movl    (sp)+,ap        /* restore linkage register */
3859          bcs    1f              /* system call sets carry bit on failure */
3860         movl    r0,r1           /* return the file descriptor */
3861         movl    $t.chan,r0      /* type channel */
3862 opnret: popr    $bit2+bit3+bit4+bit5    /* restore registers bombed by movc3 */
3863         rsb
3864
3865 1:      movl    r0,r1           /* error code to r1 */
3866         movl    $t.fix,r0
3867         clrl    r3
3868         bsbw    cons
3869         movl    $t.false,r0     /* return false with reason */
3870         brb     opnret          /* common return */
3871
3872
3873 /* close - close a channel
3874 * call:
3875 *       r1/ channel
3876 * return:
3877 *       r1/ 0 or false() if failed strangely */
3878
3879 close:  movl    $1,argn         /* count arguemtns to system */
3880         movl    r1,arg1         /* only arg is channel */
3881         pushl   ap              /* save register */
3882         movl    $argn,ap        /* arg block */
3883         chmk    $_close         /* close the file */
3884         movl    (sp)+,ap                /* restore linkage */
3885          bcs    1f
3886         movl    r0,r1           /* move returned value */
3887         movl    $t.fix,r0       /* type fix means win */
3888         rsb
3889 1:      movl    r0,r1           /* cons up a false */
3890         movl    $t.fix,r0
3891         clrl    r3
3892         bsbw    cons
3893         movl    $t.false,r0     /* type false loses */
3894         rsb
3895
3896 /* print - print string on file
3897 * call:
3898 *       r0,r1/ string
3899 *       r3/ char count
3900 *       r5/ channel
3901 * return:
3902 *       r0,r1/ number of bytes written, -1 for error */
3903
3904 print:  movl    $3,argn         /* count args */
3905         movl    r5,arg1         /* channel to arg block */
3906         movl    r1,arg2         /* string address */
3907         movl    r3,arg3         /* count of bytes */
3908         pushl   ap              /* save register */
3909         movl    $argn,ap        /* arg block */
3910         chmk    $_write
3911         movl    (sp)+,ap                /* restore linkage */
3912         bcs     prterr
3913         movl    r0,r1           /* number of bytes written */
3914         movl    $t.fix,r0       /* ok, return fix */
3915         rsb
3916 prterr: movl    r0,r1
3917         movl    $t.fix,r0
3918         clrl    r3
3919         bsbw    cons
3920         movl    $t.false,r0
3921         rsb
3922
3923 /* read - read a string
3924 * call:
3925 *       r0,r1/ string
3926 *       r3/ number of characters
3927 *       r5/ channel
3928 * return:
3929 *       r0,r1/ number of bytes read, -1 for error */
3930
3931 read:   movl    $3,argn         /* count of arguments */
3932         movl    r5,arg1         /* store channel */
3933         movl    r1,arg2         /* where to read to */
3934         movl    r3,arg3         /* how much to read */
3935         pushl   ap              /* save register */
3936         movl    $argn,ap        /* arg block */
3937         chmk    $_read
3938         movl    (sp)+,ap                /* restore linkage */
3939         movl    r0,r1           /* save count of bytes read */
3940         movl    $t.fix,r0       /* to return as fix */
3941         rsb
3942
3943 /* pipe- funny handler, because returns two values.  Call with
3944    2-element UV in r0,r1, returns false with reason or uv. */
3945
3946 dopipe: movq    r0,(r13)+
3947         pushl   ap
3948         moval   argn,ap
3949         clrl    argn
3950         chmk    $_pipe
3951         movl    (sp)+,ap
3952         bcs     nopipe
3953         movl    r0,*-4(r13)
3954         movl    -(r13),r0
3955         movl    r1,4(r0)
3956         movl    r0,r1
3957         movl    -(r13),r0
3958         rsb
3959 nopipe: movl    r0,r1
3960         movl    $t.fix,r0
3961         brw     syser
3962
3963 /* syscal -- general MIM interface to system calls in UNIX
3964 * call: args on tp stack,r1 ==> arg to chmk
3965 *                        r0 ==> # of args
3966 *               return value as a fix
3967 *                      or false with reason
3968 *       pops tp stack
3969 */
3970 syscal: movl    sp,r3                   /* use stack for args */
3971
3972         movl    r0,r4                   /* catch degenerate case */
3973          jleq   1f
3974 2:      pushl   -(r13)                  /* pop them from tp onto sp */
3975         subl2   $4,r13                  /* flush type word */
3976         sobgtr  r0,2b
3977
3978 1:      pushl   r4
3979         pushl   ap                      /* save arg pointer */
3980         moval   4(sp),ap
3981         movl    ap,lstarg
3982         movl    r1,lstcal               /* save last call for funny stuff */
3983         cmpl    r1,$_wait               /* is this a wait call? */
3984          jneq   2f                      /* no, all's well */
3985         cmpl    r4,$1
3986          jgtr   syswait                 /* alas! */
3987 2:      chmk    r1                      /* execute sys call */
3988 syser1: movl    (sp)+,ap                /* restore arg pointer */
3989         movl    r3,sp                   /* and pop stack */
3990         movl    r0,r1                   /* return value */
3991         movl    $t.fix,r0
3992          bcs    syser                   /* was there really an error */
3993         rsb
3994 syswait:
3995         movl    8(ap),r0
3996         movl    12(ap),r1
3997         bispsw  $0xf                    /* this whole thing really sucks */
3998         chmk    $_wait                  /* do it */
3999         jcs     syser1                  /* lost */
4000         tstl    4(ap)
4001          jeql   syser1
4002         movl    r1,*4(ap)               /* store status */
4003         brw     syser1
4004
4005 syser:  clrl    r3
4006         bsbw    cons                    /* cons it up */
4007         movl    $t.false,r0
4008         rsb
4009
4010 rntime: pushl   ap
4011         movl    $2,argn
4012         moval   argn,ap
4013         moval   ruse,arg2
4014         clrl    arg1
4015         chmk    $_getrusage
4016         addl3   utime,stime,r0  /* number of seconds */
4017         addl3   utime+4,stime+4,r1      /* microseconds */
4018         cvtlf   r0,r0
4019         cvtlf   r1,r1
4020         divf2   $603998836,r1   /* F floating 1000000 */
4021         addf2   r0,r1
4022         movl    $t.float,r0
4023         movl    (sp)+,ap
4024         rsb
4025
4026 /* interrupt interface to UNIX
4027    this routine is called by system when an interrupt occurs */
4028
4029 /* WARNING:  The following code contains violence and adult situations.
4030    Parental discretion is advised. */
4031
4032 .align  2                               /* align start of int routine */
4033
4034 hndlr:  .word   0                       /* register mask? */
4035         pushl   r0
4036         clrl    interr
4037         ashl    4(ap),$1,r0
4038         cmpl    4(ap),$sig_ttou
4039          jeql   hndttou                 /* do some funny stuff */
4040         mcoml   $1,interr               /* --> return error */
4041         movl    $EINTR,intval           /* with this error code */
4042         cmpl    4(ap),$sig_cont
4043          jneq   1f
4044         tstl    icall
4045          jeql   hdexit
4046 1:      bisl2   r0,intflg
4047         tstl    runint
4048          beql   2f                      /* interruptable? */
4049         brw     3f
4050 2:      cmpl    4(ap),$sig_int          /* was this ctrl-G? */
4051          jneq   hdexit                  /* no, nothing special */
4052         tstl    ingc                    /* are we in a GC? */
4053          jneq   hdcggc                  /* yes */
4054         aoblss  $3,cgct,hdexit          /* not in GC, see if panic stop */
4055         movl    12(ap),r0               /* pick up sigcontext */
4056         movl    12(r0),intgpc           /* save return pc */
4057         moval   panic1,12(r0)           /* return to our code */
4058         movl    4(r0),intmsk
4059         moval   panic1,16(r13)          /* really return to our code */
4060         brw     hdexit
4061 hdcggc: tstl    cgnois
4062          jneq   hdexit                  /* already gave message */
4063         incl    cgnois                  /* say we gave a message */
4064         pushr   $bit0+bit1+bit2+bit3+bit4+bit5
4065         moval   cgmsg1,r1
4066         movl    cgmsgl,r3
4067         clrl    r5
4068         bsbw    print
4069         popr    $bit0+bit1+bit2+bit3+bit4+bit5
4070 hdexit: movl    (sp)+,r0
4071         ret
4072 /* handle a panic stop--pc to return to is in intgpc */
4073 /* get here by changing return PC in handler */
4074 panic1: moval   panic2,16(r13)          /* just get to next section */
4075         ret
4076 panic2: movl    $1,argn
4077         movl    intmsk,arg1
4078         pushl   ap
4079         moval   argn,ap
4080         chmk    $_sigsetmask            /* change the mask */
4081         movl    (sp)+,ap
4082         addl2   $16,sp
4083         moval   panic3,(sp)             /* return to final place */
4084         rei
4085 panic3: pushl   intgpc                  /* save real return pc */
4086         cmpl    intgpc,$savstrt
4087          jleq   panic4
4088         brw     lckint                  /* and go cause an interrupt */
4089 panic4: brw     kerint                  /* interrupted from kernel */
4090
4091 3:      pushr   $bit1+bit2+bit3
4092         movl    12(ap),r1               /* pick up sigcontext */
4093         movl    12(r1),r2               /* pick up PC */
4094         cmpb    (r2)+,$_chmk            /* is it a chmk? */
4095          beql   intint
4096         brw     noskip                  /* not a chmk */
4097 intint: movzbl  (r2)+,r3                /* pick up address byte */
4098                                         /* can be register, literal, immediate */
4099         cmpb    $0x8F,r3                /* immediate? */
4100          jneq   4f
4101         movzwl  (r2)+,r3                /* pick up the frob */
4102         brb     6f
4103 4:      cmpb    $0x40,r3                /* literal? */
4104          jgtr   6f                      /* yes, have value */
4105         bicl2   $0xF0,r3                /* isolate register number */
4106          jeql   intfoo                  /* R0 not on stack */
4107         cmpl    r3,$3
4108          jleq   5f                      /* not on stack */
4109 intfoo: ashl    r3,$1,r3                /* generate mask */
4110         pushr   r3                      /* chomp */
4111         movl    (sp)+,r3                /* now have right AC in ac3 */
4112         brb     6f
4113 5:      decl    r3
4114         movl    (sp)[r3],r3             /* pick up ac off stack */
4115 6:      pushl   r4
4116         movl    intcml,r4
4117 ckloop: decl    r4
4118          jlss   9f
4119         cmpl    r3,intcmk[r4]
4120          jeql   7f
4121         brb     ckloop
4122 9:      movl    (sp)+,r4
4123 noskip: popr    $bit1+bit2+bit3         /* no, tough luck */
4124         movl    (sp)+,r0
4125         ret
4126 7:      movl    (sp)+,r4
4127         movl    r2,12(r1)               /* update PC */
4128         movl    r2,(r13)+
4129         popr    $bit1+bit2+bit3
4130         addl2   $4,sp
4131         movl    -(r13),intpcs           /* pass new PC back down */
4132         movl    12(ap),r1
4133         movl    4(r1),intmsk            /* pass old mask back down */
4134         moval   intr1,16(r13)           /* return to our code */
4135         ret
4136
4137 intr1:  moval   intr2,16(r13)           /* again */
4138         ret
4139
4140 intr2:  movl    $1,argn
4141         movl    intmsk,arg1             /* restore old mask */
4142         pushl   ap
4143         moval   argn,ap
4144         chmk    $_sigsetmask
4145         movl    (sp)+,ap
4146         movl    intval,r0               /* return error code */
4147         addl2   $16,sp                  /* clear crap off sp */
4148         movl    intpcs,(sp)             /* update PC */
4149         tstl    interr
4150          jgtr   1f                      /* only set error flag if interr -1 */
4151         bispsw  $1
4152         bisl2   $1,4(sp)
4153 1:      rei                             /* and done */
4154
4155 /* special code to handle sigttou, allowing writes to slip through,
4156    but ignoring everything else */
4157 hndttou:
4158         mcoml   $1,interr
4159         movl    $EINTR,intval
4160         cmpl    lstcal,$_write          /* were we trying a write? */
4161          jneq   3b                      /* no, just interrupt out of call */
4162         pushl   ap
4163         movl    lstarg,ap
4164         chmk    $_write                 /* should work this time */
4165         movl    r0,intval
4166          jcs    1f
4167         movl    $1,interr               /* say no error on write */
4168 1:      movl    (sp)+,ap
4169         brw     3b                      /* now fall into skip code */
4170
4171 .set    itmsl, 0                        /* length of message */
4172 .set    itmsg, 4                        /* pointer to message */
4173 .set    itfat, 8                        /* 1 if error is fatal */
4174 .set    itesiz, 12
4175 inttbl: .long   0
4176         .long   0
4177         .long   0
4178         .long   intmsl
4179         .long   intmsg
4180         .long   0
4181         .long   qutmsl
4182         .long   qutmsg
4183         .long   0
4184         .long   ilomsl
4185         .long   ilomsg
4186         .long   1
4187         .space  itesiz  /* trace trap */
4188         .space  itesiz  /* IOT */
4189         .space  itesiz  /* EMT */
4190         .long   fpemsl
4191         .long   fpemsg
4192         .long   1
4193         .space  itesiz  /* kill */
4194         .long   busmsl
4195         .long   busmsg
4196         .long   1
4197         .long   segmsl
4198         .long   segmsg
4199         .long   1
4200         .long   sysmsl
4201         .long   sysmsg
4202         .long   1
4203         .space  itesiz  /* pipe */
4204         .space  itesiz  /* alarm clock */
4205         .space  itesiz  /* stop */
4206         .space  itesiz  /* tstop */
4207         .space  itesiz  /* continue */
4208         .space  itesiz  /* child */
4209         .space  itesiz  /* ttin */
4210         .space  itesiz  /* ttout */
4211         .space  itesiz  /* io possible */
4212         .long   cpumsl
4213         .long   cpumsg
4214         .long   1
4215         .long   fszmsl
4216         .long   fszmsg
4217         .long   1
4218         .space  itesiz  /* vtalarm */
4219         .space  itesiz  /* profiling timer alarm */
4220
4221 .align  2
4222 hndseg: .word   bit0+bit1+bit2+bit3+bit4+bit5
4223         pushl   ap
4224 hndsg1: movl    12(r13),r0
4225         cmpl    12(r0),8(r0)            /* want bigger of fr and tp */
4226          jgtr   1f
4227         movl    8(r0),r0
4228         brb     2f
4229 1:      movl    12(r0),r0
4230 2:      subl3   r0,tptop,r0             /* how close are we to blowing stack? */
4231         cmpl    r0,$16
4232          jgtr   hsreal                  /* not close enough...*/
4233         cmpl    tptop,tpmax
4234          jgeq   stkflt                  /* sorry, stack's gonzo */
4235         addl3   $tp_buf,tptop,r1
4236         subl3   r1,tpmax,r3             /* max we can grow, allowing for buffer */
4237         cmpl    r3,$tp_buf
4238          jgtr   1f                      /* all OK */
4239         movl    $1,stkok                /* stack is at limit, basically */
4240         movl    tpmax,r2                /* so get a buffer, and ...*/
4241         movl    $1,r3                   /* cause interrupt */
4242 grostk: movl    $1,argn                 /* r2 has new tptop, r3 is non-zero */
4243         movl    r2,arg1                 /* if interrupt should occur */
4244         moval   argn,ap
4245         chmk    $_break
4246          jcs    stkflt                  /* growth failed */
4247         movl    (sp)+,ap
4248         movl    r2,tptop
4249         tstl    r3
4250          jeql   grosto                  /* all done */
4251         tstl    icall
4252          jeql   grosto                  /* can't interrupt if no handler */
4253         ashl    4(ap),$1,r0
4254         bisl2   r0,intflg               /* cause an interrupt */
4255 grosto: ret
4256 stkflt: moval   stklos,r1
4257         ashl    $16,stklol,r0
4258         mcoml   $1,r2
4259         bsbw    rfatal
4260         brw     hndsg1                  /* try again, may work */
4261 /* come here if room to grow stack */
4262 1:      tstl    stkok
4263          jneq   2f                      /* grow arbitrarily */
4264         addl3   $tp_buf,tptop,r2        /* get a buffer, and interrupt */
4265         movl    $1,r3
4266         brw     grostk
4267 2:      addl3   $tp_buf,tptop,r2        /* grow some */
4268         clrl    r3                      /* silently */
4269         brw     grostk
4270 hsreal: movl    $2,argn
4271         moval   limits,arg2
4272         movl    $rlimit_stack,arg1
4273         moval   argn,ap
4274         chmk    $_getrlimit             /* read stack limit */
4275         subl3   limits,$0x7fffffff,r3   /* get bottom of stack area */
4276         movl    $sig_segv,arg1
4277         moval   hndseg1,sgvec
4278         clrl    sgvec+4
4279         clrl    sgvec+8
4280         moval   sgvec,arg2
4281         chmk    $_sigvec                /* change segmentation handler */
4282         movl    (sp)+,ap
4283         movl    12(sp),r1
4284         movl    4(r1),arg1
4285         pushl   ap
4286         movl    $1,argn
4287         moval   argn,ap
4288         chmk    $_sigsetmask            /* re-enable segmentation int */
4289         movl    (sp)+,ap
4290         clrl    segerr
4291         movl    (r3),(r3)               /* try writing the location */
4292         pushl   ap
4293         movl    $sig_segv,arg1
4294         moval   hndseg,sgvec
4295         clrl    sgvec+4
4296         clrl    sgvec+8
4297         moval   sgvec,arg2
4298         movl    $2,argn
4299         moval   argn,ap
4300         chmk    $_sigvec                /* re-install old handler */
4301         movl    (sp)+,ap
4302         tstl    segerr
4303          jeql   hndrn1                  /* other segmentation error */
4304         bsbw    nomem                   /* complain */
4305         ret                             /* and done */
4306
4307 .align  2
4308 hndseg1:
4309         .word   0
4310         movl    $1,segerr               /* got error we were looking for */
4311         movl    12(ap),r1
4312         addl2   $3,12(r1)               /* skip losing instruction */
4313         movl    12(r1),intpcs           /* new pc, pass back down */
4314         moval   hndseg2,16(r13)         /* return to our code */
4315         ret
4316
4317 hndseg2:
4318         moval   hndseg3,16(r13)         /* keep returning to our code */
4319         ret
4320 hndseg3:
4321         addl2   $16,sp                  /* clear stuff off sp */
4322         movl    intpcs,(sp)             /* new PC */
4323         rei                             /* done */
4324
4325 .align  2
4326 hndrnd: .word   bit0+bit1+bit2+bit3+bit4+bit5
4327 hndrn1: subl3   $1,4(ap),r2
4328         mull2   $itesiz,r2              /* offset in inttbl */
4329         addl2   $inttbl,r2
4330         movl    itmsg(r2),r1
4331         movl    itmsl(r2),r3
4332         movl    (r3),r3
4333         clrl    r5
4334         tstl    itfat(r2)
4335          jneq   hndfat                  /* fatal error, sometimes */
4336         bsbw    print                   /* print the message */
4337         mcoml   $1,r1
4338         bsbw    quit
4339 hnddon: ret                             /* done */
4340 hndfat: ashl    $16,r3,r0
4341         tstl    ingc
4342          jneq   ifatal                  /* fatal in GC */
4343         tstl    ecall
4344          jeql   ifatal                  /* fatal if no error atom */
4345         movl    12(ap),r4               /* pick up sigcontext */
4346         movl    12(r4),intold           /* PC */
4347         movl    4(ap),intflt            /* interrupt code */
4348         moval   hndft1,16(r13)          /* return to our code */
4349         movl    4(r4),intmsk            /* pass old mask back down */
4350         ret
4351 ifatal: bsbw    rfatal
4352         jmp     comper
4353
4354 hndft1: moval   hndft2,16(r13)          /* clobber next return address */
4355         ret                             /* and return again */
4356
4357 hndft2: movl    $1,argn
4358         movl    intmsk,arg1
4359         pushl   ap
4360         moval   argn,ap
4361         chmk    $_sigsetmask
4362         movl    (sp)+,ap
4363         addl2   $16,sp
4364         moval   hndft3,(sp)             /* return from interrupt to our code */
4365         rei
4366
4367 hndft3: bsbw    iframe                          /* make a frame */
4368         movl    $t.word,(r13)+
4369         movl    intold,(r13)+
4370         movl    $t.word,(r13)+
4371         movl    intflt,(r13)+
4372         movl    $2,r0
4373         movl    ecall,r1
4374         bsbw    mcallz                  /* call error */
4375 1:      clrl    r1
4376         bsbw    quit                    /* what a chomper */
4377         brb     1b
4378
4379 .align  2
4380 hndstp: .word   bit1
4381         tstl    oldtty
4382          beql   1f
4383         pushl   ap
4384         mcoml   $1,r1
4385         bsbw    quit
4386         movl    (sp)+,ap
4387 1:      ret
4388
4389 /****************************************************************
4390 *                                                               *
4391 *                                                               *
4392 *                       Record tables                           *
4393 *                                                               *
4394 *                                                               *
4395 ****************************************************************/
4396
4397 /* first, a few definitions */
4398
4399         .set    ln.any,0
4400         .set    ln.atom,10
4401         .set    ln.frame,12
4402         .set    ln.gbind,10
4403         .set    ln.lbind,16
4404
4405 /* atom record table */
4406
4407 /* table format:
4408
4409   # elements,, type
4410   type,, length                         | one entry for each element
4411   offset in record,, code for set/get   | in the record
4412 */
4413
4414
4415 atmtbl: .word   4, ln.atom, t.gbind, ln.gbind, 0, 11, t.bind, ln.lbind
4416         .word   2, 11, t.str, ln.any, 5, 8, t.obl, ln.atom, 8, 11
4417         .word   t.typc, 0, 4, 13
4418
4419 frmtbl: .word   -8, ln.frame, t.msubr, 4, 0, 10, t.fix, 0, 2, 6, t.fix
4420         .word   16, 4, 3, t.fix, 0x912, 4, 3, t.frame, 8, 6, 10
4421         .word   t.fix, 18, 8, 3, t.bind, 0x812, 8, 3, t.fix, 0, 10, 6
4422
4423 bndtbl: .word   -6, ln.lbind, t.any, ln.any, 0, 12, t.atom, ln.atom
4424         .word   4, 11, t.any, ln.any, 6, 12, t.bind, ln.bind, 10, 11
4425         .word   t.bind, ln.bind, 12, 11, t.fix, 0, 14, 6
4426
4427 gbntbl: .word   3, ln.gbind, t.any, ln.any, 0, 12, t.atom, ln.atom, 4, 11
4428         .word   t.any, ln.any, 6, 12
4429
4430
4431 /****************************************************************
4432 *                                                               *
4433 *                                                               *
4434 *                       Boot loader                             *
4435 *                                                               *
4436 *                                                               *
4437 ****************************************************************/
4438
4439 .set    gcbase,sysbot-2000
4440 .set    gcs_addr, (((gcbase-byts_page+1)/byts_page)+1)*byts_page
4441 .set    lgcs_addr, gcs_addr-gcsizb
4442 .set    gcs_pg, gcs_addr/byts_page
4443 .set    lgcs_pg, lgcs_addr/byts_page
4444
4445 strlen: movl    (r8),r1
4446          jeql   stlndn
4447 1:      incl    r7
4448         tstb    (r1)
4449          jeql   stlndn
4450         incl    r1
4451         brb     1b
4452 stlndn: rsb
4453
4454 booter: movl    (sp),r6
4455         clrl    r7
4456         moval   4(sp),r8
4457 barglp: bsbw    strlen                  /* add len to r7 */
4458         addl2   $4,r8                   /* advance pointer */
4459         sobgtr  r6,barglp
4460         clrl    r9
4461         addl2   $4,r8                   /* move past 0 word */
4462 benvlp: tstl    (r8)
4463          beql   bblt                    /* all done */
4464         bsbw    strlen
4465         addl2   $4,r8
4466         acbl    $1024,$1,r9,benvlp      /* loop back */
4467 bblt:   addl2   $4,r9
4468         addl2   (sp),r9                 /* # of words needed for ptrs and 0s */
4469         ashl    $2,r9,r9                /* --> bytes */
4470         addl2   $3,r7
4471         bicl2   $3,r7                   /* actual number of bytes for strings */
4472         addl2   r7,r9                   /* total bytes needed */
4473         subl3   r9,$sysbot,r8           /* new top of stack */
4474         movc3   r9,(sp),(r8)            /* move everything */
4475         subl3   sp,r8,r9                /* get pointer update into r9 */
4476         movl    r8,sp
4477         moval   4(sp),r7
4478         movl    (sp),r8
4479 bargup: tstl    (r7)
4480          beql   bargud
4481         addl2   r9,(r7)
4482         addl2   $4,r7
4483         sobgtr  r8,bargup               /* loop for rest of args */
4484 bargud: addl2   $4,r7
4485 benvup: tstl    (r7)
4486          beql   benvud
4487         addl2   r9,(r7)
4488         addl2   $4,r7
4489         brb     benvup
4490 benvud: movl    (sp),numarg
4491         moval   4(sp),argbeg            /* save arg stuff */
4492         ashl    $2,(sp),r0
4493         addl2   argbeg,r0
4494         moval   4(r0),envbeg            /* beginning of environment vector? */
4495         tstl    (sp)                    /* check # args */
4496          jneq   newarg                  /* some */
4497         brw     noargs
4498 newarg: movl    4(sp),r0                /* pick up first arg */
4499         clrl    r1
4500         cmpb    (r0),$32                /* file descriptor */
4501          bgeq   cloop
4502         movl    (r0),filnam             /* pick it up */
4503         subl3   $1,(sp)+,(sp)           /* flush first arg */
4504         brw     noargs
4505 cloop:  tstb    (r0)
4506          jeql   2f
4507         incl    r0
4508         incl    r1
4509         brb     cloop
4510 2:      pushl   r1                      /* length of arg string */
4511         matchc  mudsnl,mudsnm,(sp),*8(sp)
4512          jeql   mudsub
4513         matchc  muds1l,mudsn1,(sp),*8(sp)
4514          jneq   noarg1                  /* go to noarg1 when not mudsub */
4515 mudsub: movl    (sp)+,r1
4516         cmpl    (sp),$1
4517          bleq   noargs                  /* no args to mudsub */
4518         mcoml   $1,noboot
4519         movl    4(sp),argone
4520         subl3   $1,(sp)+,(sp)           /* flush first arg */
4521         movl    (sp),numarg
4522         moval   4(sp),argbeg
4523         movl    4(sp),r0
4524         clrl    r1
4525 9:      tstb    (r0)+
4526          jeql   8f
4527         aobleq  $1024,r1,9b
4528 8:      pushl   r1
4529         locc    $46,(sp),*8(sp)         /* look for dot in name */
4530          jeql   3f                      /* not found */
4531         movl    8(sp),filnam            /* yes, no need to default */
4532         brw     noarg1
4533 3:      movc3   (sp),*8(sp),savf        /* copy the first part */
4534         movc3   $5,svname,(r3)          /* copy .save */
4535         clrb    (r3)                    /* make sure asciz */
4536         moval   savf,filnam             /* save pointer away */
4537 noarg1: movl    (sp)+,r1
4538
4539                                         /* initialize assorted things */
4540 noargs: movl    $lgcs_addr,gcsmin       /* leave 2000 words for system stack */
4541                                         /* (empirically, sp is left */
4542                                         /* at approximately 0x7fffee2c) */
4543         clrl    intflg                  /* clear the intflg at startup */
4544         clrl    spsto                   /* make sure spsto starts null */
4545         movl    tpstart,stkbot          /* put it where user code can see it */
4546         movl    tptop,stkmax
4547 /*      subl3   $02000,sp,gcsmin        */
4548         movl    gcsmin,gcstop
4549         addl3   $gcsizb,gcsmin,gcsmax   /* no limit for now */
4550
4551 /* make max size of stack area infinite */
4552
4553 setstk:
4554         movl    $rlimit_data,arg1
4555         moval   limits,arg2
4556         movl    $2,argn
4557         movl    $argn,ap
4558         chmk    $_getrlimit
4559         movl    limits+4,tpmax
4560         movl    $rlimit_stack,arg1
4561         moval   limits,arg2
4562         movl    $2,argn                 /* 2 args to vlimit */
4563         movl    $argn,ap
4564         chmk    $_getrlimit
4565         movl    limits+4,p1lim
4566         brw     cnstrt
4567
4568 /* first check to see if save file exists */
4569
4570 cnstrt: movl    filnam,r1               /* setup args for open */
4571         cmpl    r1,$100                 /* too small to be string pointer? */
4572          blss   1f
4573         pushl   ap
4574         moval   argn,ap
4575         movl    $2,argn
4576         movl    r1,arg1
4577         clrl    arg2
4578         chmk    $_open                  /* can't call openz 'cause */
4579         movl    (sp)+,ap                /* don't have memory yet */
4580          jcs    nosave
4581         movl    r0,r1
4582 1:      pushl   ap
4583         moval   argn,ap
4584         clrl    arg3
4585         movl    $3,argn
4586         clrl    sgvec+4
4587         clrl    sgvec+8
4588         moval   sgvec,arg2
4589         movl    $sig_cont,arg1
4590         moval   hndlr,sgvec
4591         chmk    $_sigvec                /* enable continue */
4592         movl    $sig_ttou,arg1
4593         moval   hndlr,sgvec
4594         chmk    $_sigvec
4595         movl    $sig_int,arg1           /* enable for some fatal interrupts */
4596         moval   hndrnd,sgvec
4597         chmk    $_sigvec
4598         movl    $sig_quit,arg1
4599         moval   hndrnd,sgvec
4600         chmk    $_sigvec
4601         movl    $sig_ill,arg1
4602         moval   hndrnd,sgvec
4603         chmk    $_sigvec
4604         movl    $sig_fpe,arg1
4605         moval   hndrnd,sgvec
4606         chmk    $_sigvec
4607         movl    $sig_bus,arg1
4608         moval   hndrnd,sgvec
4609         chmk    $_sigvec
4610         movl    $sig_segv,arg1
4611         moval   hndseg,sgvec
4612         chmk    $_sigvec
4613         movl    $sig_alrm,arg1
4614         moval   hndlr,sgvec
4615         chmk    $_sigvec                /* alarm-clock */
4616         movl    $sig_sys,arg1
4617         moval   hndrnd,sgvec
4618         chmk    $_sigvec
4619         movl    $sig_chld,arg1
4620         moval   hndlr,sgvec
4621         chmk    $_sigvec                /* inferior interrupts */
4622         movl    $sig_urg,arg1
4623         moval   hndlr,sgvec
4624         chmk    $_sigvec
4625         movl    $sig_io,arg1
4626         moval   hndlr,sgvec
4627         chmk    $_sigvec
4628         movl    $sig_pipe,arg1
4629         moval   hndlr,sgvec
4630         chmk    $_sigvec
4631         movl    $sig_tstp,arg1
4632         moval   hndstp,sgvec
4633         chmk    $_sigvec
4634         movl    $sig_xcpu,arg1
4635         moval   hndrnd,sgvec
4636         chmk    $_sigvec
4637         movl    $sig_xfsz,arg1
4638         moval   hndrnd,sgvec
4639         chmk    $_sigvec
4640         bsbw    irestor
4641         clrl    r0                      /* no args */
4642         movl    -(r13),r1
4643         bsbw    mcall
4644         bsbw    die
4645
4646 /* here to enable signals */
4647
4648 iatic:  pushl   ap
4649         pushl   r1
4650         movl    $sig_int,arg1           /* lets set up signals */
4651         cmpb    $1,r1                   /* is it control-A */
4652          jneq   1f
4653         movl    $sig_quit,arg1
4654 1:      moval   hndlr,sgvec
4655         clrq    sgvec+4
4656         movl    $3,argn
4657         clrl    arg3
4658         moval   sgvec,arg2
4659         moval   argn,ap
4660         chmk    $_sigvec
4661          bcs    sigdie
4662         movl    (sp)+,r1
4663         movl    (sp)+,ap
4664         movl    $t.fix,r0
4665         rsb
4666
4667 sigdie: movl    $siglos,r1
4668         movl    lsiglo,r3
4669         clrl    r5
4670         bsbw    print
4671         bsbw    die
4672
4673 /* initialize random variables */
4674
4675 nosave: tstl    noboot
4676          jeql   1f
4677         moval   nofile,r1
4678         movl    nofill,r0
4679         ashl    $16,r0,r0
4680         bsbw    efatal
4681 1:      pushl   ap
4682         movl    $2,argn
4683         movl    $rlimit_stack,arg1
4684         moval   limits,arg2
4685         movl    p1lim,limits
4686         movl    p1lim,limits+4
4687         chmk    $_setrlimit     /* get all you can */
4688         moval   prstart,r1      /* beginning of pure area */
4689         addl2   $pur_init,r1    /* initial size of pure area */
4690         movl    r1,tpstart      /* beginning of stack */
4691         movl    r1,r13          /* stack pointer */
4692         addl3   $tp_size,r1,tptop       /* top of stack before buffer */
4693         pushl   ap
4694         movl    $1,argn
4695         movl    tptop,arg1
4696         moval   argn,ap
4697         chmk    $_break                 /* get space for stack */
4698         movl    (sp)+,ap
4699         movl    $boomsg,r1
4700         movl    lbooms,r3
4701         clrl    r5
4702         bsbw    print
4703         movl    $boobuf,r1
4704         movl    $4,r3
4705         clrl    r5
4706         clrl    boobuf
4707         bsbw    read
4708         movzbl  boobuf,r1
4709         cmpb    r1,$'-
4710          jeql   bmone
4711         cmpb    r1,$'0
4712          jneq   bone
4713         clrl    bootyp
4714         jmp     doboot
4715 bmone:  mcoml   $0,bootyp
4716         jmp     doboot
4717 bone:   movl    $1,bootyp
4718 doboot: clrl    mdepth                  /* no nesting yet on mcalls */
4719         clrl    mtrace                  /* non-zero means trace mcalls */
4720
4721 /*      ** initialize page table **     */
4722
4723         movl    $0x40000000/byts_page,p0tbl     /* all of p0 space for now */
4724         clrl    p0tbl+4         /* starts at 0 */
4725         mcoml   $0,p0tbl+8              /* neg val means unusable */
4726         movl    $(lgcs_addr-0x40000000)/byts_page,p1tbl  /* most of p1 */
4727         movl    $0x40000000/byts_page,p1tbl+4
4728         clrl    p1tbl+8
4729         movl    $(gcs_pg-lgcs_pg),gctbl
4730         movl    $lgcs_pg,gctbl+4
4731         movl    $1,gctbl+8              /* zone 1 has gc space */
4732         movl    $(0x7fffffff-gcs_addr)/byts_page,stktbl
4733         movl    $gcs_addr/byts_page,stktbl+4
4734         mcoml   $0,stktbl+8
4735         clrl    endtbl
4736
4737 /* initialize record table */
4738
4739         movl    $t.frame,r0
4740         movl    $frmtbl,r1
4741         bsbw    brectb
4742         movl    $t.bind,r0
4743         movl    $bndtbl,r1
4744         bsbw    brectb
4745         movl    $t.atom,r0
4746         movl    $atmtbl,r1
4747         bsbw    brectb
4748         movl    $t.obl,r0
4749         movl    $atmtbl,r1
4750         bsbw    brectb
4751         movl    $t.gbind,r0
4752         movl    $gbntbl,r1
4753         bsbw    brectb
4754         movl    $t.lval,r0
4755         movl    $atmtbl,r1
4756         bsbw    brectb
4757         movl    $t.gval,r0
4758         movl    $atmtbl,r1
4759         bsbw    brectb
4760         movl    $t.link,r0
4761         movl    $atmtbl,r1
4762         bsbw    brectb
4763
4764 /* build atom hash table */
4765
4766         movl    $lhsize,r0              /* allocate space */
4767         bsbw    iblock                  /* for hash table */
4768         movl    r6,topobl+4             /* store in known place */
4769         movl    $hsize<16+t.vec,topobl  /* > size and type of table */
4770         movl    $lhsize<16+t.vec+dope,hsize*8(r6) /* dope vector for tobl */
4771
4772 /* make each bucket be a list */
4773
4774         movl    $hsize,r0               /* number of buckets */
4775         movl    $t.list,r1              /* list type */
4776 1:      movl    r1,(r6)                 /* load type word */
4777         addl2   $8,r6                   /* step through hash table */
4778         sobgtr  r0,1b                   /* loop until done */
4779
4780 /* open a channel to boot file */
4781
4782         clrl    bsendf                  /* not eof */
4783         movl    lbootf-2,r0             /* setup length */
4784         movl    $bootf,r1               /* address of name */
4785         clrl    r3                      /* mode 0 is read only */
4786         bsbw    open                    /* open the file */
4787         cmpl    r0,$t.false             /* failed? */
4788          jneq   1f
4789 godie:    bsbw  die
4790 1:      movl    r1,bschan               /* save boot channel */
4791         movl    $dum4,r11               /* point to dummy msubr vect */
4792
4793 bloop:  bsbw    bsread                  /* read an object */
4794         tstb    bsendf                  /* EOF? */
4795          jeql   bloop                   /* no, keep trying */
4796
4797         movl    bschan,r1               /* arg for close */
4798         bsbw    close                   /* close the channel */
4799
4800         movl    $s.boot,r6              /* get address of BOOT atom name */
4801         bsbw    bslkp                   /* search */
4802         tstl    r0                      /* found boot atom? */
4803          jeql   godie                   /* nope */
4804
4805 /* enter MDL environment (after all, that's what a bootstrap does) */
4806
4807         pushl   r6                      /* save boot atom pointer */
4808         bsbw    iframe                  /* make a frame */
4809         movl    r13,r12                 /* setup frame pointer */
4810         movl    $dummy,fr.msa(r12)      /* bs dummy frame */
4811         bsbw    iframe                  /* another frame */
4812
4813 /* proclaim winnage */
4814
4815         movl    $ldmsg,r1               /* message address */
4816         movl    lldmsg,r3               /* it's length */
4817         clrl    r5                      /* this means tty */
4818         bsbw    print                   /* print it */
4819
4820         movl    (sp)+,r1                /* get back boot atom */
4821         movl    $1,r0                   /* No arguments */
4822         movl    $dum4,r11               /* setup a dummy msubr */
4823         movl    $t.fix,(r13)+
4824         movl    bootyp,(r13)+
4825         bsbw    mcall                   /* do the call */
4826
4827 /* should return pointer to routine to call in r1 */
4828
4829         movl    r1,(r13)+               /* save pointer to routine */
4830
4831 /* before actually calling it, lets try to save this crud */
4832
4833         movl    filnam,r1               /* pointer to name */
4834         movl    $1,r3                   /* open for output */
4835         bsbw    openz                   /* try to open file */
4836         cmpw    r0,$t.false             /* failure? */
4837          jneq   1f                      /* no, try to write */
4838
4839         movl    $savlos,r1              /* say save loss */
4840         movl    lsavlos,r3
4841         clrl    r5
4842         bsbw    print
4843         bsbw    die                     /* die in this case */
4844
4845 1:      clrl    r0                      /* Nothing fancy on return PC */
4846         clrl    r2                      /* no extra zones yet */
4847         clrl    r3
4848         bsbw    dosave
4849
4850 /* now get back routine to call etc */
4851
4852         movl    -(r13),r1               /* and get back pointer to routine */
4853         clrl    r0
4854         bsbw    mcall                   /* try to call it (ha ha ha) */
4855         bsbw    die                     /* not yet implemented */
4856
4857
4858 /* utility subroutines for booting */
4859
4860 /* brectb - add record table
4861 * call:
4862 *       r0/ type
4863 *       r1/ record table address        */
4864
4865 brectb: ashl    $-6,r0,r0       /* isolate type */
4866         bicl2   $0xFFFFFFC0,r0  /* 6 bits */
4867         ashl    $3,r0,r0        /* make table index */
4868         movl    r1,rectbl+4(r0) /* store address */
4869         movl    $t.fix,rectbl(r0) /* legal type */
4870         rsb
4871
4872 /* bin - read a byte
4873 * call:
4874 *       bsbw    bin
4875 * return:
4876 *       r0/ byte read
4877 *       bsendf/ -1 if EOF read  */
4878
4879 bin:    movl    $3,argn         /* setup for call */
4880         movl    bschan,arg1     /* boot channel */
4881         movl    $bsinch,arg2    /* where to read to */
4882         movl    $1,arg3         /* just one byte */
4883         pushl   ap              /* save linkage */
4884         movl    $argn,ap        /* setup linkage for sys call */
4885         chmk    $_read          /* read in */
4886         movl    (sp)+,ap        /* restore linkage */
4887         tstl    r0              /* any errors? */
4888          jlss   bsioer          /* yes, die */
4889          jneq   1f              /* EOF? */
4890         movb    $0xFF,bsendf    /* yes, flag it */
4891 1:      movl    bsinch,r0       /* store byte read */
4892         rsb
4893
4894 /* bsread - read an object from boot file
4895 * call:
4896 *       bsbw    bsread
4897 * return:
4898 *       (eof read)      */
4899
4900 bsread: tstb    bsendf          /* EOF yet? */
4901         jeql    1f              /* no, keep reading */
4902          rsb                    /*  yes, return */
4903 1:      movzbl  bsbrk,r0        /* already a break character? */
4904          jneq   2f              /* no */
4905         bsbw    bin             /* bin a byte */
4906 2:      clrb    bsbrk           /* not a break character, we assume */
4907         cmpb    r0,$'|          /* vbar? */
4908          jeql   bscod           /* read code */
4909         cmpb    r0,$'#          /* sharp? */
4910          jeql   bstyp           /* type */
4911         cmpb    r0,$'[          /* ] bracket? */
4912          jeql   bsvec           /* vector */
4913         cmpb    r0,$'(          /* ) open paren? */
4914          jeql   bslst           /* list */
4915         cmpb    r0,$'"          /* " dbl-quote? */
4916          jeql   bsstr           /* string ( */
4917         cmpb    r0,$')          /* right paren? */
4918          jeql   retunb          /* oops [ */
4919         cmpb    r0,$']          /* right bracket? */
4920          jneq   chexc           /* no, try for excl */
4921 retunb: movl    r0,r6           /* return bad character */
4922         movl    $t.unb,r0
4923         rsb
4924
4925 chexc:  cmpb    r0,$'!          /* excl? */
4926          jeql   bschar          /* character */
4927         bsbw    bssep           /* seperator? */
4928          jeql   bsread          /* yes, keep reading */
4929         cmpb    r0,$'0          /* is it a number? */
4930          jlss   bsatm           /* not if less than 0 */
4931         cmpb    r0,$'9          /* or */
4932          jgtr   bsatm           /* greater than 9 */
4933                                 /* drop through to read fix */
4934 bsfix:  clrl    r1              /* indicates fix/ float */
4935         subl3   $'0,r0,r2       /* accumulate in r2 */
4936         clrl    r4              /* no fractional part yet */
4937         movl    $1,r4           /* number of digits read */
4938 bsfixl: bsbw    bin             /* read next byte */
4939         bsbw    bssep           /* seperator? */
4940         jeql    bsfixe          /* yes, tie it off */
4941         tstl    r1              /* reading fraction? */
4942         jneq    bsfix2          /* yes, go read it */
4943         cmpb    r0,$'.          /* is it a dot? */
4944          jneq   1f              /* no, add to fix */
4945           movl  $1,r1           /*  start fractoin */
4946           brb   bsfixl          /*  and continue */
4947 1:      mull2   $10,r2          /* multiply sum */
4948         subl2   $'0,r0          /* make numeric */
4949         addl2   r0,r2           /* accumulate */
4950         brb     bsfixl          /* and continue */
4951
4952 bsfix2: mull2   $10,r3          /* multiply fraction */
4953         subl2   $'0,r0          /* accumulate */
4954         addl2   r0,r3
4955         mull2   $10,r1          /* and step fractional mantissa */
4956         brb     bsfixl          /* and continue */
4957
4958 bsfixe: movb    r0,bsbrk        /* remember terminating byte */
4959         tstl    r1              /* are we floating? */
4960          jneq   bsflt           /*  yes */
4961         movl    r2,r6           /* no, fix value here */
4962         movl    $t.fix,r0       /* type */
4963         rsb
4964
4965 bsflt:  bsbw    die             /* haven't decided this yet... */
4966
4967         movl    $t.float,r0     /* but eventually, */
4968         rsb                     /* return a float */
4969
4970 /* here to read # format type */
4971
4972         .set    pnam, 8
4973
4974 bstyp:  bsbw    bsread          /* recurse to read atom */
4975         movl    pnam+4(r6),r7   /* pname **** depends on format ***** */
4976         movl    (r7),r0         /* get first 4 characters */
4977         movl    $t.msubr,r1     /* guess at msubr */
4978         cmpl    r0,s.msub       /* right? */
4979          jeql   1f              /* yes */
4980         movl    $t.imsub,r1
4981         cmpl    r0,s.imsub
4982          jeql   1f
4983         movl    $t.decl,r1
4984         cmpl    r0,s.decl
4985          jeql   1f
4986         movl    $t.unb,r1
4987         cmpl    r0,s.unbo
4988          jeql   1f
4989         movl    $t.false,r1
4990         cmpl    r0,s.fals
4991          jeql   1f
4992         bsbw    die             /* none of the above, we lose */
4993 1:      movw    r1,-(sp)        /* push type */
4994         bsbw    bsread          /* read next item */
4995         movw    (sp)+,r0        /* restore type */
4996         cmpw    $t.msubr,r0     /* is it msubr? */
4997          jeql   bsty_sg         /* yes, do SETG */
4998         cmpw    $t.imsub,r0     /* or imsubr */
4999          jeql   bsty_sg         /* ditto */
5000         rsb
5001
5002         .set    msb.name, 12
5003         .set    gb.atm, 0
5004
5005 bsty_sg: movl   msb.name(r6),r8 /* r8 is the atom now */
5006         movl    gb.atm(r8),r8   /* gbind now */
5007         movl    r0,ot(r8)       /* save type */
5008         movl    r6,ov(r8)       /* and value */
5009         rsb
5010
5011 /* here to read a character */
5012
5013 bschar: bsbw    bin             /* read the backslash */
5014         cmpb    $'/,r0          /* is it? */
5015          jneq   die             /* oh no */
5016         bsbw    bin             /* now read char */
5017         movl    t.char,r0       /* but throw it away? */
5018         rsb
5019
5020 /* read a string */
5021
5022 bsstr:  clrl    r1              /* r1 will count charcters */
5023         clrb    r2              /* indicates \ seen */
5024 bsstrl: bsbw    bin             /* read */
5025         tstb    r2              /* quoted? */
5026          jneq   bsinstr         /* yes, it stays */
5027         cmpb    r0,$'\          /* is this the quote character? */
5028          jneq   1f              /* naw */
5029         incb    r2              /* yes, flag we saw one */
5030         brb     bsstrl          /* and read next */
5031 1:      cmpb    r0,$'"          /* " end of string? */
5032          jeql   bsmaks          /* yes, make it a real string */
5033 bsinstr: movl   $t.char,(r13)+
5034         movl    r0,(r13)+       /* push the byte */
5035         incl    r1              /* count chars */
5036         clrb    r2              /* not quoted anymore */
5037         brb     bsstrl          /* and keep reading */
5038
5039 /* here to actually make a string */
5040
5041 bsmaks: movl    $t.str,r0       /* string type */
5042         bsbw    ublock          /* make a string */
5043         movl    r1,r6           /* return pointer where we need it */
5044         rsb                     /* and return */
5045
5046 /* read an atom */
5047
5048 bsatm:  clrl    r1              /* prepare count of characters */
5049         brb     bsatm1          /* and push first character */
5050
5051 bsatml: bsbw    bin             /* read next */
5052         cmpb    r0,$'\          /* quote character? */
5053          jneq   1f              /* no */
5054          bsbw   bin             /* yes, read next character */
5055          bsbw   bsatm1          /* and push it */
5056 1:      bsbw    bssep           /* separator? */
5057          jeql   bsatm3          /* yes... */
5058 bsatm1: movl    $t.char,(r13)+
5059         movl    r0,(r13)+       /* push chars on TP stack */
5060         incl    r1              /* and count them */
5061         brb     bsatml          /* keep reading */
5062
5063 bsatm3: movb    r0,bsbrk        /* save break character */
5064         movl    $t.str,r0       /* we want to make a string */
5065         bsbw    ublock          /* out of the atom name on TP stack */
5066
5067         pushl   (r1)            /* save word of chars */
5068         movq    r0,-(sp)        /* save string */
5069         bsbw    bslkp           /* lookup the atom */
5070         tstl    r6              /* was there one? */
5071          jeql   1f              /* no, add it */
5072
5073         addl2   $12,sp          /* remove string */
5074         rsb                     /* if exists, return it */
5075
5076 /* push gbind, lbind, pname, obl onto TP stack, then call record: */
5077
5078 1:      movl    $t.unb,(r13)+   /* make an unbound gbind */
5079         clrl    (r13)+
5080         clrl    (r13)+
5081         clrl    (r13)+
5082         clrl    (r13)+
5083         clrl    (r13)+
5084         movl    $t.gbind,r0     /* type */
5085         movl    $3,r1           /* number of elements */
5086         bsbw    record          /* build a gbind */
5087         movl    r0,(r13)+       /* push gbind */
5088         movl    r1,(r13)+       /* rest of gbind (value) */
5089         movl    $t.fix,(r13)+   /* lbind */
5090         clrl    (r13)+          /* to stack */
5091         movq    (sp)+,(r13)+    /* zap it onto tp stack */
5092         movl    $t.atom,r0
5093         movl    $3,r1           /* 4 elements */
5094         bsbw    record          /* build an atom */
5095         movl    r1,r6           /* return pointer where it belongs */
5096         movl    bsaptr,r2       /* put in table */
5097         movl    (sp)+,(r2)+     /* name */
5098         movl    r6,(r2)+        /* atom */
5099         movl    r2,bsaptr       /* update table pointer */
5100         rsb
5101
5102 /* lookup atom in boot table */
5103
5104 bslkp:  movl    (r6),r0         /* name to r0 */
5105         moval   bsatbl,r7       /* pointer to table */
5106 bslkpl: movl    (r7),r1         /* get name */
5107         bneq    1f              /* branch if not done yet */
5108          clrl   r6              /* done, return not found */
5109          rsb
5110 1:      cmpl    r0,r1           /* is it this one? */
5111         bneq    2f              /* nope, loop */
5112         movl    4(r7),r6        /* GOT IT - return atom pointer */
5113         movl    $t.atom,r0      /* type atom if we care */
5114         rsb
5115 2:      addl2   $8,r7           /* next entry */
5116         brb     bslkpl          /* and loop */
5117
5118
5119 /* read code */
5120 bsfoo:  brb     bscodl
5121 bscod:  clrl    r1              /* count */
5122 bscodl: bsbw    bin             /* read a byte */
5123         cmpb    r0,$'|          /* vbar? */
5124          jeql   bscod2          /* yes, end */
5125         cmpb    r0,$'0          /* is it between 0 */
5126          jlss   bsfoo
5127          jlss   bscodl          /* and 9? */
5128         cmpb    r0,$'9          /* maybe... */
5129          jleq   bscod1          /* yes, ok */
5130         cmpb    r0,$'A          /* how abouf A-F? */
5131          jlss   die
5132         cmpb    r0,$'F
5133          jgtr   die             /* no, die */
5134         subl2   $'A-'0-10,r0    /* normalize */
5135 bscod1: subl2   $'0,r0          /* make it a byte */
5136         movb    r0,(r13)+       /* push it */
5137         incl    r1              /* keep counting */
5138         brb     bscodl          /* and loop */
5139
5140 bscod2: ashl    $-1,r1,r1       /* number of bytes */
5141         movl    r1,r0           /* make spare copy */
5142         movl    r1,r9           /* save another copy */
5143         addl2   $11,r0          /* to words */
5144         ashl    $-2,r0,r0       /* round it */
5145         bsbw    iblock          /* allocate */
5146         movl    r9,r1           /* restore number of bytes */
5147         ashl    $14,r1,r0       /* count to left half (lwords) */
5148         movw    $t.mcode,r0     /* type in right */
5149         addl3   r6,r1,r7        /* point to dope words */
5150         movl    r7,r10          /* make a spare copy */
5151 bsclp:  movb    -(r13),r2       /* get a nibble from stack */
5152         movb    -(r13),r3       /* and another one */
5153         ashl    $4,r3,r3        /* shift left */
5154         bisb2   r2,r3           /* two nibbles / byte */
5155         movb    r3,-(r7)        /* put the code where it belongs */
5156         sobgtr  r1,bsclp        /* and loop for all bytes */
5157
5158         addl3   $3,r10,r1       /* round to long word */
5159         bicb2   $3,r1           /* make long address */
5160         movl    r1,r7           /* copy */
5161         addl2   $11,r9          /* round bytes to lword, plus dope */
5162         ashl    $14,r9,r9       /* shift to left half */
5163         movw    $dope+t.msubr,r9 /* set type in right half */
5164         movl    r9,(r7)         /* dope word */
5165         rsb
5166
5167 /* read a vector */
5168
5169 bsvec:  clrl    r1              /* count of elements */
5170 bsvecl: pushl   r1              /* save count */
5171         bsbw    bsread          /* read an element */
5172         movl    (sp)+,r1                /* restore count */
5173         cmpw    $t.unb,r0
5174          jneq   bsvecx
5175         cmpw    $'],r6          /* end of vector? */
5176          jeql   bsvec2          /* yes */
5177 bsvecx: movl    r0,(r13)+       /* save type */
5178         movl    r6,(r13)+       /* and value */
5179         incl    r1              /* ount elements */
5180         brb     bsvecl          /* and keep reading */
5181
5182 bsvec2: movl    $t.vec,r0       /* type to r0 */
5183         bsbw    ublock          /* build the thing */
5184         movl    r1,r6           /* return pointer in r6 */
5185         rsb
5186
5187 /* read a list */
5188
5189 bslst:  clrl    r1              /* count */
5190 bslstl: pushl   r1              /* save count */
5191         bsbw    bsread          /* read an element */
5192         movl    (sp)+,r1                /* restore count */
5193         cmpw    $t.unb,r0
5194          jneq   bslstx          /* ( */
5195         cmpb    $'),r6          /* end of list? */
5196          jeql   bslst2          /* yes, ... */
5197 bslstx: movl    r0,(r13)+       /* push type */
5198         movl    r6,(r13)+       /* and value */
5199         incl    r1              /* count */
5200         brb     bslstl          /* and looop */
5201
5202 bslst2: bsbw    blist           /* build a list */
5203         movl    r1,r6           /* save pointer */
5204         rsb
5205
5206
5207 /* check if character in r0 is a separator
5208 * call:
5209 *       r0/ character
5210 * return:
5211 *       Z condition set if separator
5212 *       (preserves all registers)       */
5213
5214 bssep:  cmpb    r0,$'"          /* quote? */
5215          jeql   1f              /* yes */
5216         cmpb    r0,$')
5217          jeql   1f
5218         cmpb    r0,$']
5219          jeql   1f
5220         cmpb    r0,$040         /* space */
5221          jeql   1f
5222         cmpb    r0,$012         /* lf */
5223          jeql   1f
5224         cmpb    r0,$015         /* cr */
5225          jeql   1f
5226         cmpb    r0,$014         /* ff */
5227          jeql   1f
5228         cmpb    r0,$26          /* ^Z */
5229          jeql   2f              /* is eof */
5230         tstb    r0              /* as is */
5231          jeql   2f              /* nul */
5232         rsb                     /* return NEQL (cuz r0 isn't 0) */
5233
5234 2:      movb    $1,bsendf       /* flag eof */
5235 1:      tstb    $0              /* be sure EQL (Z set) */
5236         rsb
5237
5238 /* death and destruxtion */
5239
5240 /* calngs -- come from mcall to here if thing being mcalled is not an atom
5241
5242         r0/     # args
5243         r1/     atom pointer
5244         r2/     pc where mcall happened (relative)
5245 */
5246
5247 calngs: tstl    ncall           /* is there an ncall atom? */
5248          jeql   ngsdie          /* no, die */
5249
5250         movl    r13,r3          /* copy TP stack pointer */
5251         addl2   $8,r13          /* room for atom to call with */
5252         movl    r0,r4           /* copy arg count */
5253         jeql    1f
5254
5255 2:      movq    -(r3),8(r3)     /* cute (I think) */
5256         sobgtr  r4,2b
5257
5258 1:      movl    $ln.atom<16+t.atom,(r3) /* make it an arg */
5259         movl    r1,4(r3)
5260         incl    r0              /* one more arg */
5261         movl    ncall,r1
5262         brw     mcallx          /* now do MCALL again*/
5263
5264 /* iacall -- here to apply aribtrary thing from user code
5265
5266         r0,r1/  thing to apply
5267         r3/     # of args
5268 */
5269
5270 iacall: cmpw    r0,$t.msubr
5271          jneq   iacal1          /* not calling an msubr */
5272         subl3   (sp)+,im.code+ov(r11),r2        /* relative return pc */
5273         movl    r1,r4           /* msubr into r4 */
5274         movl    r3,r0           /* number of args to r0 */
5275         jmp     icret           /* go for it */
5276 iacal1: tstl    ncall
5277          jeql   ngsdie
5278         movl    r13,r5
5279         addl2   $8,r13          /* room on tp stack */
5280         movl    r3,r4           /* copy count */
5281         jeql    1f
5282
5283 2:      movq    -(r5),8(r5)
5284         sobgtr  r3,2b
5285
5286 1:      movq    r0,(r5)
5287         movl    ncall,r1
5288         addl3   $1,r4,r0
5289         brw     mcall
5290
5291 discom: movl    $dismsg,r1      /* message */
5292         movl    ldisms,r3       /* length */
5293         brw     msgdie
5294
5295 ugverr: subl3   (sp),im.code+ov(r11),(sp)       /* relative return pc */
5296         movl    ecall,r1
5297          jneq   1f
5298 noeicc: movl    $commsg,r1
5299         movl    lcomms,r3
5300         brw     msgdie
5301 1:      bsbw    iframe          /* make frame */
5302         movl    $1,r0           /* one argument */
5303         movl    4(sp),r2
5304         cmpw    -4(r2),$t.atom  /* did we get atom instead of gbind? */
5305          jneq   2f
5306         movl    $(a.len<17+t.gval),(r13)+
5307         movl    (r2),(r13)+
5308         brb     3f
5309 2:      movq    -4(r2),(r13)+   /* push it */
5310 3:      bsbw    mcallz
5311         subl3   (sp)+,im.code+ov(r11),(sp)      /* flush argument */
5312         rsb                     /* return */
5313
5314 cmperr:
5315 comper: movl    ecall,r1        /* does error atom exist... */
5316          jneq   1f
5317         movl    $commsg,r1      /* get message */
5318         movl    lcomms,r3       /* length */
5319         brb     msgdie          /* say it and die */
5320
5321 1:      tstl    ingc
5322          jeql   2f
5323         moval   gcerr,r1        /* don't call error in GC */
5324         movl    lgcerr,r3
5325         brb     msgdie
5326 2:      bsbw    iframe          /* create frame for call to error */
5327         clrl    r0              /* no args to error in compiled code */
5328         brw     mcall
5329
5330 unimpl: movl    $unimsg,r1
5331         movl    lunims,r3
5332         brb     msgdie
5333
5334 bsioer: movl    $biomsg,r1
5335         movl    lbioms,r3
5336         bsbw    die
5337
5338 illdis: movl    $illmsg,r1      /* illegal dispatch address specified */
5339         movl    lillms,r3
5340         brb     msgdie
5341
5342 ngsdie: movl    $ngsmsg,r1
5343         movl    lngsms,r3
5344         brb     msgdie
5345
5346 die:    movl    $diemsg,r1
5347         movl    ldiems,r3
5348         brb     msgdie
5349
5350 msgdie: clrl    r5              /* clear channel means tty */
5351         bsbw    print           /* print message */
5352 jstdie: mcoml   $1,r1
5353         bsbw    quit
5354         jmp     comper
5355
5356 /* storage */
5357         .data
5358
5359 /* fun things */
5360
5361 spaces: .ascii  "    "                  /* 4 spaces */
5362 lesst:  .ascii  "<"
5363 gtrt:   .ascii  ">"
5364 crlf:   .byte   015                     /* CR */
5365         .byte   012                     /* LF */
5366
5367 ldmsg:  .ascii "MimiVAX loaded
5368 "
5369 lldmsg: .long   lldmsg-ldmsg
5370
5371 bootf:  .ascii "boot.msubr"
5372 lbootf: .long   lbootf-bootf
5373
5374 intmsg: .ascii  "Interrupt character typed"
5375 intmsl: .long   intmsl-intmsg
5376 qutmsg: .ascii  "Quit character typed"
5377 qutmsl: .long   qutmsl-qutmsg
5378 ilomsg: .ascii  "Illegal instruction"
5379 ilomsl: .long   ilomsl-ilomsg
5380 fpemsg: .ascii  "Floating point exception"
5381 fpemsl: .long   fpemsl-fpemsg
5382 busmsg: .ascii  "Bus error"
5383 busmsl: .long   busmsl-busmsg
5384 segmsg: .ascii  "Segmentation error"
5385 segmsl: .long   segmsl-segmsg
5386 sysmsg: .ascii  "Bad arg to system call"
5387 sysmsl: .long   sysmsl-sysmsg
5388
5389 cpumsg: .ascii  "CPU time limit exceeded"
5390 cpumsl: .long   cpumsl-cpumsg
5391 fszmsg: .ascii  "File size limit exceeded"
5392 fszmsl: .long   fszmsl-fszmsg
5393
5394 fatmsg: .ascii  "Fatal error -- "
5395 fatmsl: .long   fatmsl-fatmsg
5396
5397 dismsg: .ascii "Dispatch compiler error"
5398 ldisms: .long   ldisms-dismsg
5399
5400 commsg: .ascii "Comper death"
5401 lcomms: .long   lcomms-commsg
5402
5403 gcerr:  .ascii  "Error in GC"
5404 lgcerr: .long   lgcerr-gcerr
5405
5406 cgmsg1: .ascii  "GC running--please wait..."
5407 cgmsgl: .long   cgmsgl-cgmsg1
5408
5409 cgmsg2: .ascii  "GC done.
5410 "
5411 cgms2l: .long   cgms2l-cgmsg2
5412
5413 biomsg: .ascii  "IO error reading bootstrap"
5414 lbioms: .long   lbioms-biomsg
5415
5416 illmsg: .ascii "Illegal dispatch entry encountered"
5417 lillms: .long   lillms-illmsg
5418
5419 siglos: .ascii  "Error from signal set"
5420 lsiglo: .long   lsiglo-siglos
5421
5422 intlos: .ascii  "No interrupt handler yet"
5423 lintlos:        .long   lintlos-intlos
5424
5425 diemsg: .ascii "Die death"
5426 ldiems: .long   ldiems-diemsg
5427
5428 ngsmsg: .ascii "Calngs death"
5429 lngsms: .long   lngsms-ngsmsg
5430
5431 unimsg: .ascii "Unimplemented death"
5432 lunims: .long   lunims-unimsg
5433
5434 boomsg: .ascii "How to boot (1 big, 0 mbins, -1 msubrs):  "
5435 lbooms: .long   lbooms-boomsg
5436
5437 mudsnm: .ascii  "mudsub"
5438 mudsnl: .long   6
5439 mudsn1: .ascii  "MUDSUB"
5440 muds1l: .long   6
5441 period: .ascii  "."
5442 svname: .ascii  ".save"
5443
5444 newker: .ascii  "Loading kernel to match save file version
5445 "
5446 newkln: .long   newkln-newker
5447 savver: .ascii  "Save file uses wrong kernel version"
5448 savvel: .long   savvel-savver
5449
5450 nofile: .ascii  "Save file not found"
5451 nofill: .long   nofill-nofile
5452
5453 /* chmks that can be interrupted out of */
5454 intcmk: .long   _wait
5455         .long   _sigpause
5456         .long   _read
5457         .long   _readv
5458         .long   _write
5459         .long   _writev
5460         .long   _ioctl
5461         .long   _connect
5462         .long   _select
5463         .long   _send
5464         .long   _recv
5465         .long   _recvmsg
5466         .long   _sendmsg
5467         .long   _sendto
5468         .long   _recvfrom
5469 intcml: .long   (intcml-intcmk)/4
5470
5471 /* interrupts that muddle knows how to handle */
5472 intb1:  .byte   sig_int
5473         .byte   sig_chld
5474         .byte   sig_quit
5475         .byte   sig_cont
5476         .byte   sig_pipe
5477         .byte   sig_urg
5478         .byte   sig_io
5479         .byte   sig_segv        /* only set when we get a stack overflow */
5480 intlen: .long   intlen-intb1
5481
5482 /* translation of interrupt for muddle system (reverse order of previous
5483    table) */
5484 intb2:  .byte   0       /* never used */
5485         .byte   31
5486         .byte   32
5487         .byte   33
5488         .byte   34
5489         .byte   35
5490         .byte   1
5491         .byte   19
5492         .byte   7
5493
5494 kernam: .ascii  "/usr/mim/xmdl."
5495 verptr: .space  10              /* will be clobbered at appropriate time */
5496 homstr: .ascii  "/USR"
5497 hextr:  .byte   0
5498         .set    homlen, 4
5499         .space  15
5500 savf:   .ascii  "mim.saved"
5501 extr:   .byte   0               /* null-termminated */
5502         .set    savlen, extr-savf
5503         .space  40-savlen
5504 filnam: .long   savf            /* pointer to save file name */
5505 noboot: .long   0               /* set if running as mudsub */
5506
5507 stklos: .ascii  "Stack overflow"
5508 stklol: .long   stklol-stklos
5509
5510 restlos:
5511         .ascii  "Ran out of virtual pages"
5512 restlol:        .long   restlol-restlos
5513
5514 savlos: .ascii  "Save failed"
5515 lsavlos:        .long   lsavlos-savlos
5516
5517 /* boot string definitions */
5518
5519 s.msub: .ascii "MSUB"
5520 s.imsub: .ascii "IMSU"
5521 s.decl: .ascii "DECL"
5522 s.unbo: .ascii "UNBO"
5523 s.fals: .ascii "FALS"
5524 s.boot: .ascii "BOOT"
5525
5526 bootyp: .long   0               /* flag for boot */
5527
5528 boobuf: .long   0
5529
5530 interr: .long   0
5531 intval: .long   0
5532 lstcal: .long   0
5533 lstarg: .long   0
5534
5535 segerr: .long   0
5536
5537 argn:   .long   0               /* sys call interface block */
5538 arg1:   .long   1
5539 arg2:   .long   1
5540 arg3:   .long   1
5541
5542 intflt: .long   0
5543 intold: .long   0
5544 intpcs: .long   0
5545 intgpc: .long   0               /* saved pc for use by control-G code */
5546 intmsk: .long   0
5547
5548 ruse:
5549 utime:  .long   0               /* block for rntime call */
5550         .long   0
5551 stime:  .long   0
5552         .long   0
5553         .space  56
5554
5555 bschan: .long   0               /* bootstrap channel */
5556 bsbrk:  .long   0               /* break character to reread for boot */
5557 bsendf: .long   0               /* bs eof flag */
5558 bsinch: .long   0               /* character input buffer for boot */
5559
5560 dummy:  .long   0               /* dummy initial frame */
5561         .long   dum2
5562         .space  6
5563 dum2:   .long   dum3
5564 dum3:   .long   0
5565         .long   dum4
5566 dum4:   .long   0
5567         .long   0
5568
5569         .set    bsatlnt, 400
5570 bsatbl: .space  4*bsatlnt
5571 bsaptr: .long   bsatbl
5572
5573 oldtty: .space  7*4
5574 newtty: .space  7*4
5575
5576 argone: .long   0
5577 numarg: .long   0
5578 argbeg: .long   0
5579 envbeg: .long   0
5580
5581 p1cur:  .long   0
5582 p1lim:  .long   0
5583
5584 stkok:  .long   0                       /* set if user has OK'ed growing stack */
5585
5586 cgnois: .long   0                       /* set if ctrl-G during GC */
5587 cgct:   .long   0                       /* use to force error when in tight loop */
5588
5589 savstrt: .ascii "MIMS"                  /* used to check save file */
5590 versav: .long   0
5591         .set    pagtlen, 256
5592 pagptr: .word   t.uvec
5593         .word   pagtlen
5594 pagpt1: .long   pagtbl                  /* address of page table */
5595 pagtbl:                                 /* 256 longwords */
5596 p0tbl:  .long   0
5597         .long   0
5598         .long   0
5599 p1tbl:  .long   0
5600         .long   0
5601         .long   0
5602 gctbl:  .long   0
5603         .long   0
5604         .long   0
5605 stktbl: .long   0
5606         .long   0
5607         .long   0
5608 endtbl: .long   0
5609         .space  (4*256)-52
5610
5611 minf:   .long   minfv                   /* pointer to minf vector */
5612 minfv:  .long   2               /* input stream */
5613         .long   1               /* output stream */
5614         .long   32              /* bits/ word */
5615         .long   8               /* bits/ byte */
5616         .long   wds_page        /* words/ page */
5617         .long   4               /* bytes/ word */
5618         .long   2               /* shift for byte --> word */
5619         .long   4               /* bytes (not chars)/word */
5620         .long   4294934527      /* largest possible float */
5621         .long   4294967295      /* smallest */
5622 minfve: .set    lminf, minfve-minfv     /* set length of minf vector */
5623 rectbl: .space  256*2*4         /* 256 types, 2 words each */
5624
5625 type_count: .long t.fretyp      /* free type for user-defined */
5626
5627 ecall:  .long   0
5628 ncall:  .long   0
5629 icall:  .long   0               /* why isn't this defined in MIMIAP? */
5630 uwatm:  .long   0               /* points to unwinder atom */
5631 topobl: .long   0               /* will be loaded as type vector */
5632         .long   0               /* will be address of top oblist */
5633 framid: .long   0               /* global unique frame id */
5634 tbindt: .long   0               /* type word of top-lev binding chain */
5635 tbind:  .long   0               /* top-level binding chain */
5636 sspsto: .long   0
5637 sbindid:        .long   0       /* copy of bindid over save/restore */
5638 mtrace: .long   0               /* non-zero to trace mcalls */
5639 mdepth: .long   0               /* current depth of mcall trace */
5640 ingc:   .long   0               /* flag saying whether we are in GC */
5641 mapper: .long   0               /* points to pure-map atom */
5642 runint: .long   0               /* if non-zero, run interrupts immediately */
5643
5644 sgvec:  .long   0
5645         .long   0
5646         .long   0
5647
5648 limits: .long   0
5649         .long   0
5650 /* GC storage and definitions */
5651
5652 gcparx:
5653 rcl:
5654 gcpar:  .long   0
5655         .set    rcloff, 0       /* offset from gcparx */
5656 rclvb:  .long   0
5657         .set    rclvoff, 4      /* offset from gcparx */
5658 rclv1:  .long   0               /* recycle lists for various size blocks */
5659 rclv2:  .long   0
5660 rclv3:  .long   0
5661 rclv4:  .long   0
5662 rclv5:  .long   0
5663 rclv6:  .long   0
5664 rclv7:  .long   0
5665 rclv8:  .long   0
5666 rclv9:  .long   0
5667 rclv10: .long   0
5668         .set    max_rcl, 10
5669 gcstop: .long   0
5670         .set    gcstopo, gcstop-gcparx
5671 gcsmin: .long   0
5672         .set    gcsmino, gcsmin-gcparx
5673 gcsmax: .long   0
5674         .set    gcsmaxo, gcsmax-gcparx
5675         .set    gclnt, ((gcsmaxo+1)/4)+1
5676 czone:  .long   0               /* current zone for GC */
5677
5678 stktop: .long   0               /* save the top of the stack for save */
5679 tpstart: .long  0               /* pointer to beginning of tp stack */
5680 tptop:  .long   0               /* top of tp stack */
5681 tpmax:  .long   0               /* largest size for data space */
5682 savend: .long   0
5683 codend: .align  2               /* this is where MDL stack starts */
5684                                 /* put it on a longword boundary */
5685 prstart: .long  0