4 /* (begin long comment)
6 Various assembler requirements: here for reference:
10 no leading 0 ==> decimal
11 leading 0X (0x) ==> hex
12 floats, if I need them...
15 'C ==> ascii value of C
16 "string" ==> counted string (try this...)
19 Lfoo labels are discarded
20 n: (0 <= n <= 9) ==> local label, nb(ackwards) nf(orward) references
25 (& and) (| or) (^ xor) (> right-shift) (< left-shift) (! or-not)
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, ...
33 .SET symbol, value ==> enter SYMBOL into symbol table
35 !!! use $ instead of # !!!
36 !!! use * instead of @ !!!
41 /* Begin long comment about MDL
47 MS (r11) ;Current MSUBR pointer
49 r0 ;Type in type/value pair
52 Memory layout: (addresses are in hex)
54 P0: =========================
55 0000 0000 I dispatch I
57 =========================
60 =========================
61 000? ???? I Pure space I
62 =========================
63 000? ???? I FBIN space I
64 =========================
65 000? ???? I MDL stack I
70 3FFF FFFF .........................
72 P1: .........................
78 7FFF FAFF: I GC space I
79 =========================
81 7FFF FBFF: I SP stack I
82 =========================
85 7FFF FFFF I (1 Kword) I
86 =========================
88 (end long MDL comment) */
90 /* definitions of system calls */
108 .set _break, 17 /* seems to still exist */
114 /* .set _setuid, 23 */
116 /* .set _stime, 25 */
118 /* .set _alarm, 27 */
119 /* .set _fstat, 28 */
120 /* .set _pause, 29 */
121 /* .set _utime, 30 */
126 /* .set _ftime, 35 */
130 /* .set _setpgrp, 39 */
134 /* .set _times, 43 */
136 /* .set _setgid, 46 */
138 /* .set _signal, 48 */
151 .set _getpagesize, 64
153 /* .set _vfork, 66 */
154 /* .set _vread, 67 */
155 /* .set _vwrite, 68 */
159 /* .set _vadvise, 72 */
161 /* .set _vlimit, 77 */
171 .set _gethostname, 87
172 .set _sethostname, 88
173 .set _getdtablesize, 89
180 .set _setpriority, 96
184 .set _getpriority, 100
188 .set _setsockopt, 105
193 .set _sigsetmask, 110
198 .set _gettimeofday, 116
200 .set _getsockopt, 118
203 .set _settimeofday, 122
215 .set _socketpair, 135
220 .set _getpeername, 141
228 .set _getsockname, 150
230 /* Random definitions */
233 .set ubytes, upages*512
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
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 */
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 */
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 */
298 .set minf.len, 10 /* length of minf vector */
299 .set jmpa, 0x9f /* start of JMP abs instruction */
302 /* Type code definitions */
304 .set dope, 040 /* Dope bit for stack things */
305 .set dope_bit, 02000000
306 .set mark_bit, 0x8000
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
323 .set bit29, 004000000000
324 .set bit30, 010000000000
325 .set bit31, 020000000000
338 /* types - coded so that rightmost 3 bits are primtype */
341 .set t.any, 0 /* not REALLY a type, but.. */
343 .set shft,0100 /* used to shift type code left */
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
350 .set t.list, pt.list+shft*4
351 .set t.false, pt.list+shft*5
352 .set t.decl, pt.list+shft*6
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 */
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 */
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 */
400 /* Internal structures */
402 /* object: (may be added to xx.obj to get real offset) */
407 .set ot, 0 /* shorthand alternates for object offsets */
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 */
416 /* frame: (stack offsets) */
417 .set fr.act, -4 /* relative PC stored for AGAIN */
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) */
432 .set fr.len, 14 /* length of frame in 16-bit words */
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) */
442 .set gfr.len, 7 /* length of glued frame in 16-bit words */
446 .set c.ptr, 0 /* pointer to rest */
447 .set c.obj, 4 /* cell object */
449 /* vector, uvector, string:
450 these are arrays of [objects/ fixes/ bytes]
451 followed by the dope word */
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) */
460 .set a.len, 5 /* length in words */
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) */
469 .set lb.hdr, -4 /* header (only when on stack) (4 bytes) */
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) */
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 */
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 */
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 */
495 /* Ascii characters */
508 /* put in jump at address 0 */
509 txtstr: .word 0 /* it seems that first word is skipped */
511 .align 2 /* start dispatch table at 8 */
513 /* dispatch table - each entry is a longword - referenced by all code */
514 /* nop instructions used to align longwords */
567 brw irestor /* brw irestor */
569 brw illdis /* brw random */
589 brw illdis /* ireset ?? */
611 brw relu /* brw relu */
613 brw relr /* brw relr */
615 brw rell /* brw rell */
617 brw illdis /* brw conten */
619 brw imarkr /* brw imarkr */
621 brw imarkrq /* brw imarkrq */
623 brw illdis /* brw syscalx */
625 brw quit /* brw quit */
629 brw setzon /* brw setzon */
637 brw illdis /* brw iputs */
681 /* Utility routines for following... */
683 /* Unglue a frame, returns new frame pointer in r12 */
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 */
691 /* Print MDEPTH spaces on terminal */
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 */
699 sobgtr r2,1b /* loop for all spaces to print */
700 movl (sp)+,r2 /* restore register */
704 /************************************************************************
706 * .subtitle Stack Operations *
708 * frame, mcall, bind, legal, args, tuple, return *
709 * unbind, retry, activation, rtuple, again *
711 *************************************************************************/
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)
723 bsbw iassq /* get lbind pointer in r1 */
725 jneq isetdn /* go do it */
726 isetgr: subl3 (sp),im.code+ov(r11),(sp)
730 movl $(a.len<17+t.atom),(r13)+
735 subl3 (sp),im.code+ov(r11),(sp)
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
742 cmpl lb.bid(r1),bindid
748 lvalgr: bsbw iassq /* try to get an lbind */
753 lvalls: subl3 (sp),im.code+ov(r11),(sp)
757 movl $(a.len<17+t.atom),(r13)+
761 subl3 (sp),im.code+ov(r11),(sp)
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 */
775 /* come here if bindid doesn't match. Have to search binding chain
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 */
793 iassex: tstl lb.obj(r1) /* see if not an unbound */
794 jeql iassgfl /* lose */
797 /* ibind - push a binding
802 * (binding pushed on stack)
803 * (saves all registers) */
805 ibind: movl $(ln.lbind+2)<16+dope+t.bind,(r13)+ /* push bind header > */
806 movl r13,r1 /* save tp now */
808 clrq (r13)+ /* push a bunch of 0's (4 long words)*/
810 clrq (r13)+ /* 4 more word, sigh */
811 movl spsto,-12(r13) /* store current binding */
812 movl r1,spsto /* this is current binding now */
815 /* sframe - generate a segment frame (same as frame...) */
817 sframe: movl $fr.len<16+dope+t.sframe, (r13)+ /* push frame header */
820 /* iframe - generate an empty frame
824 * <empty frame has been pushed on TP stack> */
826 iframe: movl $fr.len<16+dope+t.frame, (r13)+ /* push frame header */
828 clrq (r13)+ /* zero rest of frame */
829 clrq (r13)+ /* zero rest of frame */
830 bisb2 $ffbit,fr.ffb(r13) /* light full-frame bit */
833 /* mcall - call an msubr
836 * r1/ MSUBR being called
838 * returns: (from msubr, eventually)
842 mcallz: movl (sp)+,r2 /* get absolute return PC */
843 jmp mcallx /* and go for it */
845 mcall: tstl mtrace /* waste a whole word */
846 beql 1f /* don't want a trace, skip it */
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 */
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 */
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 */
867 1: subl3 (sp)+,im.code+ov(r11),r2 /* get return PC from sp
869 mcallx: movl a.gbind(r1),r3 /* get global binding of atom */
871 gongs: jmp calngs /* none, complain */
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 */
878 icret: movl ov+ms.im(r4),r5 /* get imsubr atom from msubr */
879 movl a.gbind(r5),r10 /* its global binding */
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 */
887 bsbw ungfrm /* chase down real frame */
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 */
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! */
908 1: tstl ingc /* dont int if in gc */
911 movl r0,(r13)+ /* save number of args */
913 subl3 r8,im.code+ov(r11),(r13)+ /* save pc */
914 intlop: ffs $0,$32,intflg,r8
915 jeql noincl /* seems unlikely */
920 brw noincl /* muddle doesn't know about it */
922 movl $t.fix,(r13)+ /* call with correct args */
923 movzbl intb2(r0),(r13)+ /* pick up muddle interrupt number */
925 movl icall,r1 /* get pointer to int routine */
926 jeql losint /* loser */
929 bicl2 r8,intflg /* clear intflg */
931 bsbw mcallz /* call interrupt handler */
933 jneq intlop /* more to come */
934 subl3 -(r13),im.code+ov(r11),r8
940 noincl: ashl r8,$1,r8
943 subl3 -(r13),im.code+ov(r11),r8
949 losint: movl $intlos,r1
955 /* ifixbn - fix binding
959 * (must save ALL registers) */
961 ifixbn: pushl r0 /* save registers r0,r1 */
963 movl spsto,r0 /* current binding pointer to r0 */
964 1: cmpl r0,r12 /* compare to current frame */
966 movl lb.atom(r0),r1 /* get atom */
967 movl r0,a.lbind(r1) /* rebind it */
968 movl lb.prev(r0),r0 /* and chain */
971 2: movl (sp)+,r1 /* restore work registers */
976 /* ilegal - determine legality of object
981 * r0/ type (fix=true) (false=false)
982 * (must save registers) */
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 */
989 bicl3 $0xFFFFFFF8,r0,r2
991 lgltab: .word lgltru-lgltab
999 lgltru: popr $bit2+bit3
1000 movl $t.fix,r0 /* all else is legal */
1001 rsb /* so report that */
1003 lglstr: ashl $-16,r0,r2 /* get length of string */
1011 /* frob is on stack */
1013 incl r1 /* point to halfword */
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 */
1022 cmpl (r1),4(r2) /* compare the dope words */
1024 lgllos: popr $bit2+bit3
1028 lgluvc: ashl $-14,r0,r2 /* length in bytes */
1029 addl2 r2,r1 /* go to dope word */
1030 cmpl r1,tpmax /* check stack stuff */
1036 brb lgltst /* hit common code */
1038 lglfrm: cmpl r1,r13 /* check for inbounds */
1039 jgtr lglfls /* return false */
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
1046 lglwin: movl $t.fix,r0
1050 lglbnd: cmpl r1,tpmax
1051 jgtr lglwin /* case of top-level lbind */
1056 cmpl lb.head(r1),$(ln.lbind+2)<16+dope+t.bind /* bind hdr? */
1059 lglfls: movl $t.false,r0
1062 lgltup: cmpl r1,tpmax
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
1073 bicl2 $0xFFFF,r0 /* kill type */
1074 ashl $2-16,r0,r0 /* word index */
1075 cmpw (r1)[r0],$t.tuple+dope
1077 cmpw (r1)[r0],$t.tuple
1079 cmpw (r1)[r0],$t.vec+dope
1082 /* here to see if rested args of frame */
1084 movl r12,r2 /* point to current frame */
1086 lgltu1: tstb fr.ffb(r2) /* is this glued? */
1088 movl fr.act(r2),r2 /* loop back */
1091 1: cmpl r1,r2 /* if tuple pntr is above frame,
1094 movl fr.fra(r2),r2 /* previous frame */
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 */
1105 /* iargs - return argument tuple for a frame
1111 * (may mung all registers)
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 */
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)
1123 * r1/ code (see above)
1127 * (saves all registers) */
1129 igets: caseb r1,$1,$16 /* dispatch on type */
1130 getab: .word getarg-getab
1146 bsbw comper /* should never reach this */
1148 gtingc: movzwl $t.fix,r0
1152 gtbind: movq tbindt,r0
1155 getarg: movzwl fr.arg(r12),r1 /* get number of args */
1156 movzbl $t.fix,r0 /* and type */
1159 grunin: movzwl $t.fix,r0
1163 getobl: movq topobl,r0 /* type, value */
1166 getbnd: movl spsto,r1 /* current binding */
1167 movl $(ln.lbind<16+t.bind),r0 /* > type word */
1170 gecall: movl ecall,r1 /* get current ecall */
1171 brb retatm /* and return atom */
1173 gncall: movl ncall,r1 /* current ncall */
1176 gicall: movl icall,r1 /* current icall */
1179 guwatm: movl uwatm,r1 /* current uwatom */
1180 retatm: movl $(a.len<17+t.atom),r0 /* > type word */
1183 gpgptr: movq pagptr,r0 /* current page pointer */
1186 getmnf: movl minf,r1 /* current minf */
1187 movl $(minf.len<16+t.uvec),r0 /* > type */
1190 gmappe: movl mapper,r1 /* current mapper */
1193 /* Can clobber r0,r1 */
1194 genvir: movl envbeg,r0 /* Start of environment vec (set up by booter) */
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 */
1209 aobleq $1024,r1,3b /* aos count, loop back */
1211 bsbw ublock /* Make the vector */
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 */
1222 movl (r0),r2 /* point to a string */
1227 2: movw $t.str,(r13)+
1229 movl (r0),(r13)+ /* Push the string */
1237 gargn: movw $t.false,r0
1241 ghomst: movw $homlen,r0
1247 /* sets - codes as in gets above
1249 * r0/ type (not checked)
1250 * r1/ value to store
1256 isets: caseb r3,$1,$16 /* dispatch on type */
1257 setab: .word seter-setab /* args - error */
1259 .word setbnd-setab /* binding - error */
1267 .word senvir-setab /* a no-op */
1268 .word senvir-setab /* for argv--does nothing */
1269 .word senvir-setab /* for homstr--does nothing */
1273 seter: bsbw comper /* should never reach this */
1275 stingc: movl r1,ingc
1278 stbind: movq r0,tbindt
1281 srunin: movl $t.fix,(r13)+ /* push relative PC */
1282 subl3 (sp)+,im.code+ov(r11),(r13)+
1285 bsbw kerint /* handle pending interrupts */
1286 movl -(r13),runint /* set up flag */
1288 subl3 -(r13),im.code+ov(r11),-(sp) /* restore PC */
1292 setobl: movq r0,topobl
1294 setbnd: movl r1,spsto
1296 secall: movl r1,ecall
1298 sicall: movl r1,icall
1300 sncall: movl r1,ncall
1302 suwatm: movl r1,uwatm
1304 spgptr: movq r0,pagptr
1306 setmnf: movl r1,minf
1308 smappe: movl r1,mapper
1311 /* incall - internal call
1315 * frame set up, with
1316 * return address 3 bytes after bsb (after brw)
1317 * new frame has same MS, otherwise new */
1319 incall: subl3 (sp),im.code+ov(r11),r6 /* get return address
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 */
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 */
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 */
1340 /* iret - MSUBR return code */
1343 iret: bsbw frmfix /* unravel the frame */
1344 1: subl3 r7,im.code+ov(r11),r7 /* unrelativize PC */
1345 jmp (r7) /* PC returned here */
1348 /* frmfix - unravel frame, leaving return PC in r7 */
1350 frmfix: tstb fr.ffb(r12) /* is it a glued frame? */
1351 blss fixrel /* no, fix real 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 */
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 */
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 */
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 */
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 */
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 */
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 */
1407 /* iunbind - unbind entry from external world
1409 * call: r1/ saved SP pointing to binding
1410 * (may mung all registers except r0-r1 pair)
1412 * (unbinding done) */
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? */
1420 movl lb.atom(r6),r9 /* point to atom */
1421 jeql un.1 /* none */
1422 cmpl r9,uwatm /* unwinder? */
1423 jeql dounwi /* yes - unwind */
1425 unjoin: movl lb.last(r6),a.lbind(r9) /* get last binding */
1427 movl lb.prev(r6),r6 /* next binding */
1428 brb iunbnl /* loop */
1430 iunbnd: movl r6,spsto /* store current binding */
1432 /* this used to fixup tp, but clr claims it don't have to no more */
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 */
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... */
1450 movl $(ln.bind<16+t.bind),(r13)+ /* > */
1454 jmp 0(r9) /* call unwinder */
1456 /* here to exit from unwinder */
1458 unwcnt: movl -4(r13),r8 /* restore saved registers */
1460 subl2 $16,r13 /* fix stack */
1461 movq -(r13),r0 /* restore real return values */
1463 movl r12,r3 /* for FRMFIX */
1465 brw unjoin /* rejoin common code */
1467 /* iactiv - setup activation
1469 (saves all registers) */
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 */
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 */
1482 movl (sp)+,r0 /* and r0 */
1485 /* iretry - retry a frame
1487 r1/ frame to retry */
1489 retry: movl r1,r12 /* new frame pointer */
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 */
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... */
1507 /* sblock - ublock for stack
1509 * r0/ type of structure
1510 * r1/ # of frobs on stack (not same as size)
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.
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. */
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 */
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 */
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 */
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 */
1554 jeql 3f /* empty structure */
1555 2: movl 4(r2),(r0)+ /* move an element */
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 */
1564 brw sbret /* all done */
1566 sblb: movl $t.bytes,r5 /* type word */
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 */
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 */
1582 3: addw2 2(r0),r2 /* add length of frob */
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 */
1588 bicb2 $3,r3 /* number of bytes needed */
1589 ashl $14,r3,r4 /* number of words in LH */
1591 bisl2 $dope,r4 /* r4 is dope word */
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 */
1601 movl r4,(r1)+ /* first dope word */
1602 movl r1,(sp) /* pointer to new structure */
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 */
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 */
1616 2: clrb (r1)+ /* padding byte */
1618 1: movl r4,(r1)+ /* stuff out dope word */
1619 movl r1,r13 /* update tp */
1620 movl (sp)+,r1 /* pop pointer */
1622 bicw3 $dope,r4,r0 /* make up pointer */
1623 addl2 $4,sp /* clean up stack */
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 */
1632 /* uninitialized stack objects. r0 is type, r1 is # of elements in
1637 bicb3 $0374,r0,r2 /* isolate primtype */
1638 caseb r2,$0,$3 /* dispatch */
1639 usbd: .word usblb-usbd
1644 usblb: movl $t.bytes,r0 /* type */
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 */
1653 bisl2 $dope,r3 /* turn on dope bit */
1654 movl r3,(r13)+ /* push first dope word */
1655 pushl r13 /* pointer */
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 */
1663 movl r1,r0 /* make type word */
1664 movl (sp)+,r1 /* restore pointer */
1665 movl (sp)+,r3 /* restore saved acs */
1669 usblu: movl $t.uvec,r0
1670 ashl $2,r1,r2 /* number of bytes needed */
1671 brw usblg /* go build it */
1673 usblv: ashl $16,r1,r2
1674 movw $t.vec,r2 /* type word */
1675 pushl r1 /* save length */
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 */
1686 popr $bit3+bit4+bit5 /* first dope word */
1689 moval 8(r2),r13 /* update tp pointer */
1698 * r1/ pointer to tuple */
1701 ashl $3,r1,r0 /* get byte count of tuple into r0 */
1702 subl3 r0,r13,r1 /* point to tuple */
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 */
1711 rsb /* and return */
1713 /* irtuple - return a tuple to a frame
1714 * mretur - same thing for special multi-return case
1716 * r1/ number of args
1718 * r7/ still has return address from someplace
1720 * r0/ cnt,, type (=tuple)
1721 * r1/ pointer to tuple */
1723 mretur: pushl $1 /* flag saying this mreturn */
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 */
1735 cmpl fr.head(r2),$fr.len<16+dope+t.sframe
1736 jeql mret3 /* if this is a seg call, go return */
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? */
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 */
1756 /* here to do a comperr that eventually call interpreters MRETURN */
1759 subl3 r4,r13,r4 /* r4 now points to 1st elemet to return */
1760 bsbw iframe /* build a frame */
1762 movl $ln.frame<16+t.frame,(r13)+ /* pass the frame */
1766 jeql 1f /* if no args, go */
1768 2: movq (r4)+,(r13)+
1771 1: addl2 $1,r0 /* one more arg */
1773 bsbw mcallz /* call it */
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 */
1787 subl2 r3,r8 /* make room for tuple */
1788 2: movq (r8)+,(r13)+ /* push stuff */
1789 sobgtr r0,2b /* and iterate */
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 */
1796 2: ashl $-3,r3,r1 /* num elements to r1 */
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 */
1816 sobgtr r8,2b /* and iterate */
1817 movl r3,r13 /* fix tp */
1818 tstl r6 /* rtuple or mreturn */
1827 /* lckint - who knows ?? */
1835 3: movl $t.word,(r13)+
1842 2: movl $t.fix,(r13)+
1843 subl3 (sp)+,im.code+ov(r11),(r13)+ /* save pc */
1847 lcklop: ffs $0,$32,intflg,r2
1849 locc r2,intlen,intb1
1855 movzbl intb2(r0),(r13)+
1857 movl icall,r1 /* get frob */
1867 cmpw -4(r13),$t.fix /* maybe relativize return pC*/
1869 subl3 (sp),im.code+ov(r11),(sp)
1872 noint: ashl r2,$1,r2
1879 subl3 (sp),im.code+ov(r11),(sp)
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 */
1905 movl -4(r13),r12 /* pop the possible glued frame */
1906 jmp (r0) /* jump into code */
1908 /* newtype - create a new type code
1912 * r1/ new type code */
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 */
1921 /* typewc - return type code of type word
1923 * return: r1/ type-c
1925 typewc: bicl2 $0xFFFF0000,r1 /* kill any length info */
1929 /* typew - return type word
1930 * call: r0/ type-c of frob; r1/ type-c of primtype
1931 * return: r0, r1 type-w, value
1933 typew: cmpzv $0,$3,r1,$pt.rec /* is primtype a record? */
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 */
1941 1: movl r0,r1 /* Otherwise, just type-c */
1942 movl $t.typw,r0 /* with a different type word */
1945 /********************************************************
1948 * Storage Allocators *
1951 ********************************************************/
1953 /* blist - build list
1955 * r1/ number of elements
1956 * (tp) elements have been pushed on stack
1958 * r1/ pointer to list */
1960 blist: subl2 im.code+ov(r11),(sp)
1961 pushl r1 /* save element count */
1962 jeql 2f /* if none, done */
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 */
1972 addl2 $4,sp /* discard element count on stack */
1973 addl2 im.code+ov(r11),(sp)
1978 bvecto: halt /* not implemented */
1980 /* birec - build record or string (zeroed)
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)
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 */
2008 /* uublock - allocate an unitialized user object (string, vector, uvector)
2009 called like ublock, except nothing on stack */
2012 subl2 im.code+ov(r11),(sp)
2013 bicb3 $0374,r0,r2 /* primtype */
2014 movl r1,r9 /* save length */
2016 uubd: .word uublb-uubd /* bytes */
2022 uublb: movl $t.bytes,r4
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 */
2029 bsbw birecr /* call record-builder */
2030 uubret: addl2 im.code+ov(r11),(sp)
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 */
2039 /* vector has to be zeroed before return, to keep GC happy */
2041 ashl $1,r1,r3 /* # words */
2044 bsbb vecclr /* clear the vector */
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 */
2054 /* ublock - allocate a user object (string, vector, uvector)
2058 * (TP) elements are on stack
2061 * r1/ pointer to object
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 */
2078 ublb: movl $t.bytes,r5
2083 ubls: movl $t.str,r5 /* type */
2085 pushl r1 /* save # frobs on stack */
2087 jeql 4f /* empty string */
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 */
2101 movl (sp)+,r1 /* get # elts on stack back */
2102 jeql ublsdn /* test for 0-length string */
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 */
2116 ublsdn: ashl $16,r0,r4 /* copy number of words to left half */
2117 movw r5,r4 /* put right type in dope word */
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 */
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 */
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 */
2146 /* vector generation */
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 */
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 */
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)
2172 /* tmptbl - add a record description to table */
2174 tmptbl: ashl $3,r0,r0 /* make long index */
2175 addl2 $rectbl,r0 /* pointer to table */
2176 movq r1,(r0) /* store info */
2179 /* record - build a record
2182 * r1/ number of elements
2183 * (tp) elements on stack
2186 * (record is built) */
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) */
2219 /* loop to move elements:
2224 recorl: movzwl 2(r8)[r1],r5 /* get dispatch code for put */
2226 /* ashl $1,r5,r5 and shift it */
2227 ashl $1,r10,r10 /* both of its */
2228 movl (r11),r3 /* value */
2230 bsbw prcas /* call appropriate move routine */
2231 addl2 $8,r11 /* step elements */
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 */
2241 movl (sp)+,r11 /* restore MS */
2242 addl2 im.code+ov(r11),(sp) /* unrelativize */
2245 /* cons - build a list element
2247 * r3/ list to cons to
2252 icons: subl2 im.code+ov(r11),(sp)
2254 addl2 im.code+ov(r11),(sp)
2257 cons: movl czone,r9 /* a zone set up? */
2259 movl gcpoff(r9),r4 /* yes, use it */
2261 1: moval rcl,r4 /* no zone */
2262 consa: movl rcloff(r4),r9
2263 jeql cons1 /* get from iblock */
2265 movl -4(r9),rcloff(r4) /* pull off chain */
2266 subl2 $4,r6 /* of free cons cells */
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 */
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 */
2284 brw consa /* try again */
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 */
2292 /* iblock - interface to storage allocation
2294 * r0/ number of words needed
2296 * r6/ pointer to block
2297 * (saves all other registers used) */
2299 iblock: bitl r0,$0xffff0000
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 */
2308 2: casel r0,$2,$max_rcl-2 /* go to the right place */
2309 ibtab: .word iblokl-ibtab
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 */
2330 iblokr: popr $bit0+bit1+bit2+bit3+bit4+bit7 /* restore a few registers */
2334 /* r0 has # words wanted, r4 has gc-params. Return in r6 */
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 */
2350 /* exact match (we should be so lucky) */
2352 ibbeq: movl (r2),(r6) /* splice out of chain */
2354 ashl $2,r0,r0 /* words--> bytes */
2355 subl2 r0,r2 /* point to beginning of block */
2358 brb iblokr /* and go home winner */
2360 /* inexact match, leave tailings */
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 */
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 */
2372 subl2 r3,r2 /* point to beg of block */
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
2389 popr $bit1+bit5+bit8+bit9+bit10
2392 /* rung - run users GC */
2395 movl czone,r1 /* must have a zone */
2401 movl gcfoff(r1),r1 /* pointer to gc function */
2408 /* recycle a list cell (in r0, r1) */
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 */
2417 movl (sp)+,r0 /* don't step on any acs */
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 */
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 */
2436 reluby: movzwl 2(sp),r0 /* get # bytes */
2438 ashl $-2,r0,r0 /* # longwords */
2441 reluuv: movzwl 2(sp),r0
2444 reluvc: movzwl 2(sp),r0
2446 reluc: moval 4(r1)[r0],r0 /* point to second dope word */
2447 bsbb rclb /* go do it */
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
2465 moval -gcpoff+rcl,r2
2466 2: movl gcpoff(r2),r2 /* pick up gc-params */
2471 addl2 rcltab[r1],r2 /* point at right slot */
2472 tstl rcltab[r1] /* are we a `long' block? */
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 */
2481 rcldon: popr $bit2+bit3+bit4+bit5
2483 4: movl r2,r1 /* r1 is now something else */
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. */
2489 jeql rclin1 /* at end of chain, just splice in */
2491 blss rclin /* keep chain in ascending order */
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 */
2500 subl3 r3,r2,r3 /* beginning of next block */
2501 cmpl r0,r3 /* adjacent blocks? */
2503 rclin1: movl r0,(r1) /* no, splice into chain */
2506 1: addw2 -2(r0),-2(r2) /* adjacent, just update length */
2507 clrq -4(r0) /* zero the dope words */
2512 .long 8 /* two-word blocks */
2515 .long 0 /* five-word */
2522 /* setzon -- set current free storage zone
2524 r1/ new zone or 0 to return the current
2525 if r1 is 0 and no zone, return UVECTOR of gcparams
2527 setzon: tstl r1 /* new one supplied? */
2528 jneq 1f /* yes, set it up */
2530 movl czone,r1 /* is there one to return? */
2531 jeql 2f /* no return gcparams */
2533 movl $(zlnt<16+t.zone),r0
2537 tstl ingc /* were we in a GC? */
2539 tstl cgnois /* waiting for ctrl-G? */
2541 clrl cgnois /* clear the flag */
2542 pushr $bit0+bit1+bit2+bit3+bit4+bit5
2546 bsbw print /* print a message */
2547 popr $bit0+bit1+bit2+bit3+bit4+bit5
2551 movl $(gclnt<16+t.uvec),r0
2554 /****************************************************************
2560 ****************************************************************/
2562 /* swnxt -- sweep next
2563 call: r0,r1 --> current object, and returned next object
2564 r2--> gc-params to use
2567 swnxt: pushr $bit2+bit3 /* save temp reg */
2568 tstl r1 /* is this first time */
2569 bneq 1f /* no, not first, time to sweep */
2571 movl gcstopo(r2),r1 /* start at top */
2572 1: cmpl gcsmino(r2),r1 /* see if done */
2575 movl $t.fix,r0 /* return 0 */
2577 swret: popr $bit2+bit3
2580 2: bicl2 $0xFFFFFFC0,r0 /* isolate primtype */
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 */
2591 1: movzwl -6(r1),r0 /* get dw length */
2592 ashl $2,r0,r2 /* to bytes */
2593 subl2 $2,r0 /* fixup count */
2595 bicw3 $dope+mark_bit,-8(r1),r3 /* get type */
2596 subl2 r2,r1 /* r1 point to start */
2597 bicl3 $0xFFFFFFC0,r3,r2
2599 swtab: .word comper-swtab
2608 swbyt: ashl $2,r0,r0
2610 swrec: ashl $1,r0,r0
2612 swvec: ashl $-1,r0,r0
2613 swdone: bisw2 r3,r0 /* turn on type in return word */
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
2622 nexts: pushl r0 /* save extra register */
2623 tstl r1 /* first time? */
2624 jneq 1f /* no sweep */
2626 movl czone,r0 /* get current zone */
2627 movl gcpoff(r0),r0 /* point gc params */
2632 mcoml $0,ingc /* prevent ints for a while */
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 */
2640 7: cmpw $dope+t.tuple,r0 /* just skip tuple dope words */
2642 cmpw $dope+t.vec,r0 /* in whatever form they come */
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 */
2651 nodop: cmpw $t.tuple,r0 /* tuple? */
2652 jeql 2f /* marked when encountered */
2653 cmpw $t.qfram,r0 /* quick frame */
2655 addl2 $gfr.len*2,r1 /* skip it */
2659 3: cmpl r13,r1 /* see if end of stack */
2662 nextrt: movl (sp)+,r0
2664 nxtdop: cmpw $t.tuple,r0
2665 jeql 2b /* skip tuple dope words */
2668 cmpw $t.qfram,r0 /* and glued frames */
2672 9: cmpzv $0,$3,r0,$pt.rec /* other records get returned */
2674 movzwl 2(r1),r0 /* get word length */
2675 ashl $2,r0,r0 /* turn into bytes */
2676 addl2 r0,r1 /* move past this */
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)+
2686 movl tpstart,(r1)+ /* get beginning of stack */
2689 moval -8(r13),(r1)+ /* current top of stack */
2692 addl3 $tp_buf,tptop,(r1)+ /* max top of stack */
2698 addl3 $pur_init,$prstart,(r1)+ /* top of buffer space */
2701 moval prstart,(r1)+ /* bottom of buffer space */
2702 getskd: movl -(r13),r1
2707 jeql 1f /* return current state */
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 */
2721 bitl $dope,(r1) /* are we looking at a dope word? */
2722 jneq movdop /* yes */
2725 bitl $7,(r1) /* are we looking at a pointer? */
2726 jeql movldn /* no, skip it */
2728 cmpl r2,r13 /* pointer above top of stack? */
2730 cmpl r2,tpstart /* below bottom? */
2732 addl2 r0,4(r1) /* update the frob */
2733 movldn: addl2 $8,r1 /* and move on */
2735 movdop: bicl3 $dope,(r1),r2 /* turn off dope bit */
2736 cmpzv $0,$3,r2,$pt.vec /* tuples, vectors, etc. */
2738 cmpzv $0,$3,r2,$pt.rec /* see if a record */
2739 jneq movstr /* no, just random structure */
2740 cmpw $t.bind,r2 /* lbind */
2742 addl2 $fr.len*2,r1 /* move to end of frame */
2743 addl2 r0,fr.fra(r1) /* update frame pointer */
2745 movstr: ashl $-14,r2,r2 /* get bytes in structure */
2746 addl2 r2,r1 /* update pointer */
2747 brw movlop /* and move on */
2754 addl2 r0,lb.prev(r1)
2755 1: movl lb.last(r1),r2
2760 addl2 r0,lb.last(r1)
2761 2: addl2 $ln.bindb,r1 /* move to end */
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 */
2767 movdon: addl2 r0,spsto /* update binding chain start */
2768 /* now blt the stack */
2770 2: addl3 r0,tptop,arg1
2776 movl (sp)+,ap /* get memory */
2778 jcs movflt /* frob failed */
2780 subl3 r1,r13,r2 /* current stack length */
2784 addl2 r0,tptop /* update kernel's stack pointers */
2785 movl tptop,stkmax /* save for compiled code to look at */
2788 movc3 r2,(r1),(r3) /* blt the stack */
2794 nomem: pushr $bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit9+bit10+bit11+bit12
2797 mcoml $1,r2 /* keep the loser from dying */
2799 popr $bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit9+bit10+bit11+bit12
2802 imarkr: cmpl r1,r13 /* anything on the stack is not marked */
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 */
2812 bisw2 $0x8000,(r1) /* mark it */
2815 jeql 2f /* just mark it */
2816 movl r3,4(r1) /* store relocation */
2818 1: bicw2 $0x8000,(r1) /* kill bit */
2822 tstl r0 /* check type ac */
2823 jeql 3b /* leave on zero type word */
2824 cmpl r1,r13 /* anything on the stack is marked */
2833 tstb 1(r1) /* marked? */
2835 movl 4(r1),r1 /* any reloc pointer */
2844 /****************************************************************
2847 * Structure manipulators *
2850 ****************************************************************/
2852 /* nthu - nth of string/ vector/ uvector
2858 * r0-r1/ type-value */
2860 nthu: bicl2 $0xFFFFFFFC,r0 /* isolate primtype */
2861 caseb r0,$0,$3 /* dispatch on type */
2862 nutab: .word nthub-nutab
2866 bsbw comper /* any other type is fatal */
2873 nthus: addl2 r2,r1 /* point to byte */
2874 movzbl (r1),r1 /* get byte */
2875 movl t.char,r0 /* type char */
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?) */
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 */
2890 /* nthr - nth of a record
2893 * r1/ pointer to record
2894 * r2/ element number
2896 * r0,r1/ type,value */
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 */
2922 /* out of range drops through to error */
2924 nthrer: bsbw cmperr /* die horrible death */
2929 /* *** how to extract boolean? *** */
2932 /* drop through to common return */
2934 nthrts: popr $bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit10
2940 nthrlf: movl (r7)[r2],r0
2944 /* 3 1/2 word structure */
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 */
2953 /* structure of known length */
2955 nthrs2: movl (r7)[r2],r0 /* type */
2956 movl (r6)[r3],r1 /* pointer */
2957 jeql nthrfl /* return false? */
2958 brb nthrts /* no, just return */
2962 nthra: movl (r6)[r3],r0 /* type */
2963 movl 4(r6)[r3],r1 /* value */
2966 /* special type-c case */
2968 nthrhw: ashl $1,r3,r1
2969 cvtwl (r6)[r1],r1 /* get type code or -1 */
2970 jlss 1f /* jump if false */
2978 /* restu - rest uv, v, str
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 */
2994 bsbw cmperr /* others lose */
2998 rstuv: ashl $3,r3,r3 /* adjust count for vector thing */
3000 bgtr 1f /* above top of stack */
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 */
3010 rstuu: ashl $2,r3,r3 /* adjust count for uvec thing */
3011 movw $t.uvec,-4(r13) /* fix saved type */
3014 rstub: movw $t.bytes,-4(r13)
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 */
3027 backu: mnegl r3,r3 /* its like a negative */
3028 bsbw restu /* rest */
3029 mnegl r3,r3 /* restore r3 */
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 */
3054 topus1: movzwl 6(sp),r0 /* get length */
3055 addl2 r0,r1 /* point to dope word */
3060 brw topust /* stack case */
3061 1: bicl3 $0xFFFFFFFC,r1,-(sp) /* extra chars */
3062 addl2 $3,r1 /* round to full word boundary */
3064 topsdn: movzwl 2(r1),r0 /* total length to r0 */
3065 subl2 $2,r0 /* not counting dope words */
3067 subl2 r0,r1 /* point to top */
3074 movw r2,r0 /* string primtype */
3076 addl2 $4,sp /* fix stack */
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 */
3082 1: movl $2,-(sp) /* at least two bytes in last word */
3083 3: tstw (r1) /* if zero, haven't hit dopeword yet */
3085 addl2 $2,r1 /* advance pointer to dope word */
3087 2: addl2 $2,(sp) /* already at dopeword, 2 more in last word */
3088 bicl2 $0xFFFFFFFC,(sp) /* but never more than 3 */
3093 topuu: movzwl 2(sp),r0 /* get length */
3097 subl2 $2,r0 /* don't count dope words */
3107 topuv: movzwl 2(sp),r0
3109 addl2 r0,r1 /* get to dope words */
3110 movzwl 2(r1),r0 /* get count from dw */
3115 bisw2 $t.vec,r0 /* get type */
3119 /* putu - put vector, etc
3123 * r2/ element number
3126 * (new value in place) */
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
3140 putus: movb r4,(r1)[r2] /* store byte */
3144 putuu: movl r4,(r1)[r2] /* index does right thing */
3148 putuv: movq r3,(r1)[r2] /* magic index mode */
3154 * (args as in PUTU) */
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 */
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 */
3184 /* out of range drops through to error */
3186 putrer: bsbw cmperr /* die horrible death */
3193 /* drop through to common return */
3195 putrts: popr $bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit10
3201 putrlf: addl2 r6,r10 /* calc address */
3202 movl r4,(r10) /* store value */
3205 /* 3 1/2 word structure */
3207 putrs3: addl2 r6,r10 /* calculate address */
3208 cmpw $t.false,r3 /* false? */
3209 jeql putrsx /* naw */
3218 /* fixed length item */
3220 putrs2: cmpw $t.false,r2 /* false? */
3221 jneq putrlf /* no */
3231 /* special type-c hack */
3233 putrhw: addl2 r6,r10 /* calculate address */
3236 movw r4,0(r10) /* store type-c */
3239 1: mcomw $0,0(r10) /* indicate false */
3244 cinth: bicb2 $0x0F8,r0 /* isolate 3 bits */
3245 caseb r0,$1,$6 /* dispatch */
3246 cintab: .word cindbl-cintab
3253 /* errors drop through */
3256 cindbl: movq (r1),r0
3259 cinfby: movzbl (r1),r1
3263 cinbyt: movzbl (r1),r1
3267 cinuvc: movl (r1),r1
3274 extzv $0,$3,r0,r9 /* get rightmost 3 bits */
3275 caseb r9,$1,$6 /* dispatch */
3276 cirtab: .word cirlst-cirtab
3286 cirlst: movl $t.list,r0
3301 decw 2(sp) /* fix count */
3302 movl (sp)+,r0 /* is this a kludge? */
3325 cigas: tstl (r1) /* test gval slot */
3326 jeql 1f /* anything? */
3327 rsb /* yes, gassigned */
3328 1: movl $t.false,r0 /* nope, return false */
3334 cigvl: movl (r1),r1 /* get gval */
3337 1: movq (r1),r0 /* get type and all */
3343 bicb2 $0x0F8,r0 /* isolate 3 bits */
3345 cietab: .word cielst-cietab
3355 cielst: movl (sp)+,r0
3357 jneq cieln1 /* non-skip return */
3358 cieln2: addl2 $3,(sp) /* skip return (must skip a brw ins) */
3361 cielen: movl (sp)+,r0
3363 jlequ cieln2 /* skip */
3369 bicb2 $0x0F8,r0 /* isolate 3 bits */
3371 cimtbl: .word cimtru-cimtbl
3380 cimtru: movl (sp)+,r0
3381 brb cieln2 /* skip return */
3384 /* fatal -- complain, then depart from mim */
3386 efatal: movl $1,r2 /* this one will kill the process */
3394 rfatal: pushr $bit0+bit1+bit2+bit3+bit4+bit5
3396 bsbw fixtty /* get the tty back into shape */
3401 movl 4(sp),r1 /* get the string pointer back */
3405 popr $bit0+bit1+bit2+bit3+bit4+bit5
3412 rfatex: movl r2,arg1
3422 movl r0,arg1 /* only poke this process */
3430 /* quit -- depart from mim. Arg in r1; if >= 0, do exit */
3434 bsbw fixtty /* fix up tty */
3436 jgeq 1f /* jump if doing exit */
3451 /* Call with address in r1 of block for fixing/breaking tty */
3453 jneq 1f /* jump if stuff is there */
3461 chmk $_ioctl /* set sgttyb stuff */
3466 chmk $_ioctl /* local modes */
3471 chmk $_ioctl /* other characters */
3474 chmk $_ioctl /* local characters */
3478 /* Call with state structure in r0,r1; copy stuff out of oldtty if there,
3479 else return false */
3485 1: pushr $bit0+bit1+bit2+bit3+bit4+bit5
3486 movc3 $6,oldtty,*4(r1)
3490 movc3 $6,12(r0),*20(r1)
3493 movc3 $6,18(r0),*28(r1)
3494 popr $bit0+bit1+bit2+bit3+bit4+bit5
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. */
3511 1: pushr $bit2+bit3+bit4+bit5
3514 movc3 $6,*4(r0),(r1) /* copy chars */
3520 movc3 $6,*20(r0),12(r1)
3523 movc3 $6,*28(r0),18(r1)
3524 popr $bit2+bit3+bit4+bit5
3527 /* save r1 --> channel upon which to do save
3528 r2-->0 or frozen space
3529 r3-->0 or pure space */
3531 isave: movl (sp),r0 /* return PC */
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 */
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 */
3554 sloop: movl 4(r4),r5 /* pick up area */
3555 movl amin(r5),r3 /* maybe empty zone */
3558 movl abot(r5),(r13)+
3559 movl amax(r5),(r13)+
3571 bsbb zonect /* save params for atom zone */
3574 bsbb zonect /* save params for pure zone */
3576 bsbb zonect /* main zone */
3577 /* r0 has total count of areas */
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 */
3589 movl tpstart,r1 /* beginning of tp stack */
3590 subl3 r1,r13,r3 /* size of tp stack */
3592 bsbw print /* write out tp stack */
3595 movl (sp),r5 /* channel back */
3598 bsbb zonesv /* save atom zone */
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 */
3618 addl2 $16,sp /* flush garbage from sp */
3619 brb 4b /* clean up tp, return */
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 */
3626 subl3 r1,abot(r3),r3 /* size of area */
3627 pushl r4 /* save list */
3629 movl (sp)+,r4 /* get list back */
3630 cmpw r0,$t.false /* print lost */
3632 movl -4(r4),r4 /* rest it */
3633 jneq 2b /* loop if more */
3635 movl (sp)+,r4 /* fix up sp */
3637 /* irestor -- r1/ --> channel */
3643 movl r0,(sp) /* dorest returns PC in r0 */
3648 dorest: pushl r1 /* save channel */
3654 bsbw read /* read version number */
3655 cmpl versav,$version
3656 jneq verlost /* different version, lose immediate */
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 */
3669 chmk $_break /* make sure have space for stack */
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 */
3680 bsbw read /* read in TP stack */
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? */
3692 subl3 r3,$0x7FFFFFFF,r1 /* yes, get distance from top of p1 */
3693 cmpl r1,p1cur /* already have that much? */
3695 vagain: movl p1lim,limits+4 /* No, grow p1 */
3696 movl r1,p1cur /* say we grew it */
3699 movl $rlimit_stack,arg1
3703 chmk $_setrlimit /* do system call */
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 */
3715 jgtr reslop /* jump if more areas */
3717 movl (sp)+,r1 /* get channel back */
3719 movl stktop,r13 /* get the correct tp back */
3720 movl -(r13),r12 /* restore frame */
3722 movl $rlimit_data,arg1
3727 movl limits+4,tpmax /* absolute top of stack */
3728 movl $rlimit_stack,arg1
3729 moval limits,arg2 /* store structure */
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? */
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 */
3745 movl -(r13),r0 /* get return PC back */
3753 tstl noboot /* see if mudsub during startup */
3765 vermud: movl $1,argn
3769 chmk $_close /* close save file */
3772 verlo1: movl versav,r0
3773 clrl r1 /* make sure will work as quad */
3776 1: ediv r3,r0,r4,r0 /* quotient to r1, remainder to r0 */
3780 verls1: addb3 r4,$48,(r2)+ /* deposit the byte */
3795 movl argone,(r2) /* if mudsub, get org jcl */
3799 moval argone,(r2) /* save file descriptor (funny str)*/
3806 chmk $_execve /* try to load the right kernel */
3807 moval savver,r1 /* failed if get here */
3811 /* allocate pages */
3813 mpages: bsbw cmperr /* unimplemented */
3816 /****************************************************************
3822 ****************************************************************/
3824 /* open - open a channel to a file
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
3830 * r0/ type (channel)
3831 * r1/ file-descriptor
3832 * (the file is positioned at byte 0)
3833 * (all registers saved) */
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 */
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 */
3849 movl 8(sp),arg2 /* get former r3 off stack */
3850 jneq 1f /* jump if write--this may not work, but isn't */
3852 chmk $_open /* open the file */
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 */
3865 1: movl r0,r1 /* error code to r1 */
3869 movl $t.false,r0 /* return false with reason */
3870 brb opnret /* common return */
3873 /* close - close a channel
3877 * r1/ 0 or false() if failed strangely */
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 */
3886 movl r0,r1 /* move returned value */
3887 movl $t.fix,r0 /* type fix means win */
3889 1: movl r0,r1 /* cons up a false */
3893 movl $t.false,r0 /* type false loses */
3896 /* print - print string on file
3902 * r0,r1/ number of bytes written, -1 for error */
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 */
3911 movl (sp)+,ap /* restore linkage */
3913 movl r0,r1 /* number of bytes written */
3914 movl $t.fix,r0 /* ok, return fix */
3923 /* read - read a string
3926 * r3/ number of characters
3929 * r0,r1/ number of bytes read, -1 for error */
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 */
3938 movl (sp)+,ap /* restore linkage */
3939 movl r0,r1 /* save count of bytes read */
3940 movl $t.fix,r0 /* to return as fix */
3943 /* pipe- funny handler, because returns two values. Call with
3944 2-element UV in r0,r1, returns false with reason or uv. */
3946 dopipe: movq r0,(r13)+
3963 /* syscal -- general MIM interface to system calls in UNIX
3964 * call: args on tp stack,r1 ==> arg to chmk
3966 * return value as a fix
3967 * or false with reason
3970 syscal: movl sp,r3 /* use stack for args */
3972 movl r0,r4 /* catch degenerate case */
3974 2: pushl -(r13) /* pop them from tp onto sp */
3975 subl2 $4,r13 /* flush type word */
3979 pushl ap /* save arg pointer */
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 */
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 */
3992 bcs syser /* was there really an error */
3997 bispsw $0xf /* this whole thing really sucks */
3998 chmk $_wait /* do it */
3999 jcs syser1 /* lost */
4002 movl r1,*4(ap) /* store status */
4006 bsbw cons /* cons it up */
4016 addl3 utime,stime,r0 /* number of seconds */
4017 addl3 utime+4,stime+4,r1 /* microseconds */
4020 divf2 $603998836,r1 /* F floating 1000000 */
4026 /* interrupt interface to UNIX
4027 this routine is called by system when an interrupt occurs */
4029 /* WARNING: The following code contains violence and adult situations.
4030 Parental discretion is advised. */
4032 .align 2 /* align start of int routine */
4034 hndlr: .word 0 /* register mask? */
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
4048 beql 2f /* interruptable? */
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 */
4059 moval panic1,16(r13) /* really return to our code */
4062 jneq hdexit /* already gave message */
4063 incl cgnois /* say we gave a message */
4064 pushr $bit0+bit1+bit2+bit3+bit4+bit5
4069 popr $bit0+bit1+bit2+bit3+bit4+bit5
4070 hdexit: movl (sp)+,r0
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 */
4076 panic2: movl $1,argn
4080 chmk $_sigsetmask /* change the mask */
4083 moval panic3,(sp) /* return to final place */
4085 panic3: pushl intgpc /* save real return pc */
4086 cmpl intgpc,$savstrt
4088 brw lckint /* and go cause an interrupt */
4089 panic4: brw kerint /* interrupted from kernel */
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? */
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? */
4101 movzwl (r2)+,r3 /* pick up the frob */
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 */
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 */
4114 movl (sp)[r3],r3 /* pick up ac off stack */
4123 noskip: popr $bit1+bit2+bit3 /* no, tough luck */
4127 movl r2,12(r1) /* update PC */
4129 popr $bit1+bit2+bit3
4131 movl -(r13),intpcs /* pass new PC back down */
4133 movl 4(r1),intmsk /* pass old mask back down */
4134 moval intr1,16(r13) /* return to our code */
4137 intr1: moval intr2,16(r13) /* again */
4141 movl intmsk,arg1 /* restore old mask */
4146 movl intval,r0 /* return error code */
4147 addl2 $16,sp /* clear crap off sp */
4148 movl intpcs,(sp) /* update PC */
4150 jgtr 1f /* only set error flag if interr -1 */
4153 1: rei /* and done */
4155 /* special code to handle sigttou, allowing writes to slip through,
4156 but ignoring everything else */
4160 cmpl lstcal,$_write /* were we trying a write? */
4161 jneq 3b /* no, just interrupt out of call */
4164 chmk $_write /* should work this time */
4167 movl $1,interr /* say no error on write */
4169 brw 3b /* now fall into skip code */
4171 .set itmsl, 0 /* length of message */
4172 .set itmsg, 4 /* pointer to message */
4173 .set itfat, 8 /* 1 if error is fatal */
4187 .space itesiz /* trace trap */
4188 .space itesiz /* IOT */
4189 .space itesiz /* EMT */
4193 .space itesiz /* kill */
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 */
4218 .space itesiz /* vtalarm */
4219 .space itesiz /* profiling timer alarm */
4222 hndseg: .word bit0+bit1+bit2+bit3+bit4+bit5
4224 hndsg1: movl 12(r13),r0
4225 cmpl 12(r0),8(r0) /* want bigger of fr and tp */
4230 2: subl3 r0,tptop,r0 /* how close are we to blowing stack? */
4232 jgtr hsreal /* not close enough...*/
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 */
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 */
4246 jcs stkflt /* growth failed */
4250 jeql grosto /* all done */
4252 jeql grosto /* can't interrupt if no handler */
4254 bisl2 r0,intflg /* cause an interrupt */
4256 stkflt: moval stklos,r1
4260 brw hndsg1 /* try again, may work */
4261 /* come here if room to grow stack */
4263 jneq 2f /* grow arbitrarily */
4264 addl3 $tp_buf,tptop,r2 /* get a buffer, and interrupt */
4267 2: addl3 $tp_buf,tptop,r2 /* grow some */
4268 clrl r3 /* silently */
4270 hsreal: movl $2,argn
4272 movl $rlimit_stack,arg1
4274 chmk $_getrlimit /* read stack limit */
4275 subl3 limits,$0x7fffffff,r3 /* get bottom of stack area */
4281 chmk $_sigvec /* change segmentation handler */
4288 chmk $_sigsetmask /* re-enable segmentation int */
4291 movl (r3),(r3) /* try writing the location */
4300 chmk $_sigvec /* re-install old handler */
4303 jeql hndrn1 /* other segmentation error */
4304 bsbw nomem /* complain */
4310 movl $1,segerr /* got error we were looking for */
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 */
4318 moval hndseg3,16(r13) /* keep returning to our code */
4321 addl2 $16,sp /* clear stuff off sp */
4322 movl intpcs,(sp) /* new PC */
4326 hndrnd: .word bit0+bit1+bit2+bit3+bit4+bit5
4327 hndrn1: subl3 $1,4(ap),r2
4328 mull2 $itesiz,r2 /* offset in inttbl */
4335 jneq hndfat /* fatal error, sometimes */
4336 bsbw print /* print the message */
4339 hnddon: ret /* done */
4340 hndfat: ashl $16,r3,r0
4342 jneq ifatal /* fatal in GC */
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 */
4354 hndft1: moval hndft2,16(r13) /* clobber next return address */
4355 ret /* and return again */
4357 hndft2: movl $1,argn
4364 moval hndft3,(sp) /* return from interrupt to our code */
4367 hndft3: bsbw iframe /* make a frame */
4374 bsbw mcallz /* call error */
4376 bsbw quit /* what a chomper */
4389 /****************************************************************
4395 ****************************************************************/
4397 /* first, a few definitions */
4405 /* atom record table */
4410 type,, length | one entry for each element
4411 offset in record,, code for set/get | in the record
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
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
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
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
4431 /****************************************************************
4437 ****************************************************************/
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
4445 strlen: movl (r8),r1
4454 booter: movl (sp),r6
4457 barglp: bsbw strlen /* add len to r7 */
4458 addl2 $4,r8 /* advance pointer */
4461 addl2 $4,r8 /* move past 0 word */
4463 beql bblt /* all done */
4466 acbl $1024,$1,r9,benvlp /* loop back */
4468 addl2 (sp),r9 /* # of words needed for ptrs and 0s */
4469 ashl $2,r9,r9 /* --> bytes */
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 */
4483 sobgtr r8,bargup /* loop for rest of args */
4490 benvud: movl (sp),numarg
4491 moval 4(sp),argbeg /* save arg stuff */
4494 moval 4(r0),envbeg /* beginning of environment vector? */
4495 tstl (sp) /* check # args */
4496 jneq newarg /* some */
4498 newarg: movl 4(sp),r0 /* pick up first arg */
4500 cmpb (r0),$32 /* file descriptor */
4502 movl (r0),filnam /* pick it up */
4503 subl3 $1,(sp)+,(sp) /* flush first arg */
4510 2: pushl r1 /* length of arg string */
4511 matchc mudsnl,mudsnm,(sp),*8(sp)
4513 matchc muds1l,mudsn1,(sp),*8(sp)
4514 jneq noarg1 /* go to noarg1 when not mudsub */
4515 mudsub: movl (sp)+,r1
4517 bleq noargs /* no args to mudsub */
4520 subl3 $1,(sp)+,(sp) /* flush first arg */
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 */
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
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 */
4547 /* subl3 $02000,sp,gcsmin */
4549 addl3 $gcsizb,gcsmin,gcsmax /* no limit for now */
4551 /* make max size of stack area infinite */
4554 movl $rlimit_data,arg1
4560 movl $rlimit_stack,arg1
4562 movl $2,argn /* 2 args to vlimit */
4568 /* first check to see if save file exists */
4570 cnstrt: movl filnam,r1 /* setup args for open */
4571 cmpl r1,$100 /* too small to be string pointer? */
4578 chmk $_open /* can't call openz 'cause */
4579 movl (sp)+,ap /* don't have memory yet */
4591 chmk $_sigvec /* enable continue */
4595 movl $sig_int,arg1 /* enable for some fatal interrupts */
4615 chmk $_sigvec /* alarm-clock */
4621 chmk $_sigvec /* inferior interrupts */
4641 clrl r0 /* no args */
4646 /* here to enable signals */
4650 movl $sig_int,arg1 /* lets set up signals */
4651 cmpb $1,r1 /* is it control-A */
4654 1: moval hndlr,sgvec
4667 sigdie: movl $siglos,r1
4673 /* initialize random variables */
4683 movl $rlimit_stack,arg1
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 */
4697 chmk $_break /* get space for stack */
4715 bmone: mcoml $0,bootyp
4717 bone: movl $1,bootyp
4718 doboot: clrl mdepth /* no nesting yet on mcalls */
4719 clrl mtrace /* non-zero means trace mcalls */
4721 /* ** initialize page table ** */
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
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
4737 /* initialize record table */
4764 /* build atom hash table */
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 */
4772 /* make each bucket be a list */
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 */
4780 /* open a channel to boot file */
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? */
4790 1: movl r1,bschan /* save boot channel */
4791 movl $dum4,r11 /* point to dummy msubr vect */
4793 bloop: bsbw bsread /* read an object */
4794 tstb bsendf /* EOF? */
4795 jeql bloop /* no, keep trying */
4797 movl bschan,r1 /* arg for close */
4798 bsbw close /* close the channel */
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 */
4805 /* enter MDL environment (after all, that's what a bootstrap does) */
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 */
4813 /* proclaim winnage */
4815 movl $ldmsg,r1 /* message address */
4816 movl lldmsg,r3 /* it's length */
4817 clrl r5 /* this means tty */
4818 bsbw print /* print it */
4820 movl (sp)+,r1 /* get back boot atom */
4821 movl $1,r0 /* No arguments */
4822 movl $dum4,r11 /* setup a dummy msubr */
4825 bsbw mcall /* do the call */
4827 /* should return pointer to routine to call in r1 */
4829 movl r1,(r13)+ /* save pointer to routine */
4831 /* before actually calling it, lets try to save this crud */
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 */
4839 movl $savlos,r1 /* say save loss */
4843 bsbw die /* die in this case */
4845 1: clrl r0 /* Nothing fancy on return PC */
4846 clrl r2 /* no extra zones yet */
4850 /* now get back routine to call etc */
4852 movl -(r13),r1 /* and get back pointer to routine */
4854 bsbw mcall /* try to call it (ha ha ha) */
4855 bsbw die /* not yet implemented */
4858 /* utility subroutines for booting */
4860 /* brectb - add record table
4863 * r1/ record table address */
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 */
4872 /* bin - read a byte
4877 * bsendf/ -1 if EOF read */
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 */
4890 movb $0xFF,bsendf /* yes, flag it */
4891 1: movl bsinch,r0 /* store byte read */
4894 /* bsread - read an object from boot file
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? */
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 */
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 */
4952 bsfix2: mull2 $10,r3 /* multiply fraction */
4953 subl2 $'0,r0 /* accumulate */
4955 mull2 $10,r1 /* and step fractional mantissa */
4956 brb bsfixl /* and continue */
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 */
4965 bsflt: bsbw die /* haven't decided this yet... */
4967 movl $t.float,r0 /* but eventually, */
4968 rsb /* return a float */
4970 /* here to read # format type */
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? */
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 */
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 */
5011 /* here to read a character */
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? */
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? */
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 */
5039 /* here to actually make a string */
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 */
5048 bsatm: clrl r1 /* prepare count of characters */
5049 brb bsatm1 /* and push first character */
5051 bsatml: bsbw bin /* read next */
5052 cmpb r0,$'\ /* quote character? */
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 */
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 */
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 */
5073 addl2 $12,sp /* remove string */
5074 rsb /* if exists, return it */
5076 /* push gbind, lbind, pname, obl onto TP stack, then call record: */
5078 1: movl $t.unb,(r13)+ /* make an unbound gbind */
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 */
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 */
5102 /* lookup atom in boot table */
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 */
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 */
5115 2: addl2 $8,r7 /* next entry */
5116 brb bslkpl /* and loop */
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 */
5127 jlss bscodl /* and 9? */
5128 cmpb r0,$'9 /* maybe... */
5129 jleq bscod1 /* yes, ok */
5130 cmpb r0,$'A /* how abouf A-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 */
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 */
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 */
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 */
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 */
5182 bsvec2: movl $t.vec,r0 /* type to r0 */
5183 bsbw ublock /* build the thing */
5184 movl r1,r6 /* return pointer in r6 */
5189 bslst: clrl r1 /* count */
5190 bslstl: pushl r1 /* save count */
5191 bsbw bsread /* read an element */
5192 movl (sp)+,r1 /* restore count */
5195 cmpb $'),r6 /* end of list? */
5196 jeql bslst2 /* yes, ... */
5197 bslstx: movl r0,(r13)+ /* push type */
5198 movl r6,(r13)+ /* and value */
5200 brb bslstl /* and looop */
5202 bslst2: bsbw blist /* build a list */
5203 movl r1,r6 /* save pointer */
5207 /* check if character in r0 is a separator
5211 * Z condition set if separator
5212 * (preserves all registers) */
5214 bssep: cmpb r0,$'" /* quote? */
5220 cmpb r0,$040 /* space */
5222 cmpb r0,$012 /* lf */
5224 cmpb r0,$015 /* cr */
5226 cmpb r0,$014 /* ff */
5228 cmpb r0,$26 /* ^Z */
5229 jeql 2f /* is eof */
5232 rsb /* return NEQL (cuz r0 isn't 0) */
5234 2: movb $1,bsendf /* flag eof */
5235 1: tstb $0 /* be sure EQL (Z set) */
5238 /* death and destruxtion */
5240 /* calngs -- come from mcall to here if thing being mcalled is not an atom
5244 r2/ pc where mcall happened (relative)
5247 calngs: tstl ncall /* is there an ncall atom? */
5248 jeql ngsdie /* no, die */
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 */
5255 2: movq -(r3),8(r3) /* cute (I think) */
5258 1: movl $ln.atom<16+t.atom,(r3) /* make it an arg */
5260 incl r0 /* one more arg */
5262 brw mcallx /* now do MCALL again*/
5264 /* iacall -- here to apply aribtrary thing from user code
5266 r0,r1/ thing to apply
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 */
5279 addl2 $8,r13 /* room on tp stack */
5280 movl r3,r4 /* copy count */
5291 discom: movl $dismsg,r1 /* message */
5292 movl ldisms,r3 /* length */
5295 ugverr: subl3 (sp),im.code+ov(r11),(sp) /* relative return pc */
5298 noeicc: movl $commsg,r1
5301 1: bsbw iframe /* make frame */
5302 movl $1,r0 /* one argument */
5304 cmpw -4(r2),$t.atom /* did we get atom instead of gbind? */
5306 movl $(a.len<17+t.gval),(r13)+
5309 2: movq -4(r2),(r13)+ /* push it */
5311 subl3 (sp)+,im.code+ov(r11),(sp) /* flush argument */
5315 comper: movl ecall,r1 /* does error atom exist... */
5317 movl $commsg,r1 /* get message */
5318 movl lcomms,r3 /* length */
5319 brb msgdie /* say it and die */
5323 moval gcerr,r1 /* don't call error in GC */
5326 2: bsbw iframe /* create frame for call to error */
5327 clrl r0 /* no args to error in compiled code */
5330 unimpl: movl $unimsg,r1
5334 bsioer: movl $biomsg,r1
5338 illdis: movl $illmsg,r1 /* illegal dispatch address specified */
5342 ngsdie: movl $ngsmsg,r1
5346 die: movl $diemsg,r1
5350 msgdie: clrl r5 /* clear channel means tty */
5351 bsbw print /* print message */
5361 spaces: .ascii " " /* 4 spaces */
5364 crlf: .byte 015 /* CR */
5367 ldmsg: .ascii "MimiVAX loaded
5369 lldmsg: .long lldmsg-ldmsg
5371 bootf: .ascii "boot.msubr"
5372 lbootf: .long lbootf-bootf
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
5389 cpumsg: .ascii "CPU time limit exceeded"
5390 cpumsl: .long cpumsl-cpumsg
5391 fszmsg: .ascii "File size limit exceeded"
5392 fszmsl: .long fszmsl-fszmsg
5394 fatmsg: .ascii "Fatal error -- "
5395 fatmsl: .long fatmsl-fatmsg
5397 dismsg: .ascii "Dispatch compiler error"
5398 ldisms: .long ldisms-dismsg
5400 commsg: .ascii "Comper death"
5401 lcomms: .long lcomms-commsg
5403 gcerr: .ascii "Error in GC"
5404 lgcerr: .long lgcerr-gcerr
5406 cgmsg1: .ascii "GC running--please wait..."
5407 cgmsgl: .long cgmsgl-cgmsg1
5409 cgmsg2: .ascii "GC done.
5411 cgms2l: .long cgms2l-cgmsg2
5413 biomsg: .ascii "IO error reading bootstrap"
5414 lbioms: .long lbioms-biomsg
5416 illmsg: .ascii "Illegal dispatch entry encountered"
5417 lillms: .long lillms-illmsg
5419 siglos: .ascii "Error from signal set"
5420 lsiglo: .long lsiglo-siglos
5422 intlos: .ascii "No interrupt handler yet"
5423 lintlos: .long lintlos-intlos
5425 diemsg: .ascii "Die death"
5426 ldiems: .long ldiems-diemsg
5428 ngsmsg: .ascii "Calngs death"
5429 lngsms: .long lngsms-ngsmsg
5431 unimsg: .ascii "Unimplemented death"
5432 lunims: .long lunims-unimsg
5434 boomsg: .ascii "How to boot (1 big, 0 mbins, -1 msubrs): "
5435 lbooms: .long lbooms-boomsg
5437 mudsnm: .ascii "mudsub"
5439 mudsn1: .ascii "MUDSUB"
5442 svname: .ascii ".save"
5444 newker: .ascii "Loading kernel to match save file version
5446 newkln: .long newkln-newker
5447 savver: .ascii "Save file uses wrong kernel version"
5448 savvel: .long savvel-savver
5450 nofile: .ascii "Save file not found"
5451 nofill: .long nofill-nofile
5453 /* chmks that can be interrupted out of */
5469 intcml: .long (intcml-intcmk)/4
5471 /* interrupts that muddle knows how to handle */
5472 intb1: .byte sig_int
5479 .byte sig_segv /* only set when we get a stack overflow */
5480 intlen: .long intlen-intb1
5482 /* translation of interrupt for muddle system (reverse order of previous
5484 intb2: .byte 0 /* never used */
5494 kernam: .ascii "/usr/mim/xmdl."
5495 verptr: .space 10 /* will be clobbered at appropriate time */
5496 homstr: .ascii "/USR"
5500 savf: .ascii "mim.saved"
5501 extr: .byte 0 /* null-termminated */
5502 .set savlen, extr-savf
5504 filnam: .long savf /* pointer to save file name */
5505 noboot: .long 0 /* set if running as mudsub */
5507 stklos: .ascii "Stack overflow"
5508 stklol: .long stklol-stklos
5511 .ascii "Ran out of virtual pages"
5512 restlol: .long restlol-restlos
5514 savlos: .ascii "Save failed"
5515 lsavlos: .long lsavlos-savlos
5517 /* boot string definitions */
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"
5526 bootyp: .long 0 /* flag for boot */
5537 argn: .long 0 /* sys call interface block */
5545 intgpc: .long 0 /* saved pc for use by control-G code */
5549 utime: .long 0 /* block for rntime call */
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 */
5560 dummy: .long 0 /* dummy initial frame */
5570 bsatbl: .space 4*bsatlnt
5571 bsaptr: .long bsatbl
5584 stkok: .long 0 /* set if user has OK'ed growing stack */
5586 cgnois: .long 0 /* set if ctrl-G during GC */
5587 cgct: .long 0 /* use to force error when in tight loop */
5589 savstrt: .ascii "MIMS" /* used to check save file */
5592 pagptr: .word t.uvec
5594 pagpt1: .long pagtbl /* address of page table */
5595 pagtbl: /* 256 longwords */
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 */
5625 type_count: .long t.fretyp /* free type for user-defined */
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 */
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 */
5650 /* GC storage and definitions */
5655 .set rcloff, 0 /* offset from gcparx */
5657 .set rclvoff, 4 /* offset from gcparx */
5658 rclv1: .long 0 /* recycle lists for various size blocks */
5670 .set gcstopo, gcstop-gcparx
5672 .set gcsmino, gcsmin-gcparx
5674 .set gcsmaxo, gcsmax-gcparx
5675 .set gclnt, ((gcsmaxo+1)/4)+1
5676 czone: .long 0 /* current zone for GC */
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 */
5683 codend: .align 2 /* this is where MDL stack starts */
5684 /* put it on a longword boundary */