:TITLE[Ops.0mc, June 29, 1983 3:42 PM, vanMelle];

* Swap, op 375, Swap TOS and TOS-2
@Swap:
loadpage[pgHStack], call[checkElt2P7], opcode[375];
Stack&-3, call[Swap1];
Stack&+2 ← T;
Stack&-1, call[Swap1];
Stack&+2 ← T, goto[nxiLBL];

Swap1:T ← Stack&+2;
Stack&-2 ← Stack&-2, return;


* Eq, op 360, Compare TOS and TOS-2, push T or Nil if eq or not, resp
@Eq:
loadpage[pgHStack], call[checkElt2P7], opcode[360];
StkState ← rsh[StkState, 1];
T ← Stack&-2;
lu ← (Stack&+1) xor T;
T ← Stack&-2, FreezeResult, skip[alu#0];
lu ← (Stack) xor T;* If lolocs were eq, test hi’s
T ← Stack ← 0c, skip[alu#0];* about to push T or NIL...
Stack&+1 ← (KtVal), goto[nxiLBL];
PushTP7:
Stack&+1 ← T, goto[nxiLBL];


* Nop , op 376, Nop
@Nop:
NextOpCode, opcode[376];


* Pop , op 277, Pop stack, ignore the item
@Pop:
Stack&-2, goto[PopChk6], opcode[277];


* Listp, op 003, Replace TOS with Nil if TOS is not a list
@Listp:
call[lspTyp], opcode[003];
lu ← (lspType) - (listType);
TOSGetsNILifNeq:* Replace TOS with NIL if alu#0
skip[alu#0];
NextOpCode;
T ← Stack&-1 ← 0c;
PushTP4:
Stack&+1 ← T, goto[nxiLBL];


* Ntypx, op 004, Replace TOS with type of TOS
@Ntypx:
call[lspTyp], opcode[004];* pop stack, get type in T and Type
Stack&-1 ← (smallpl), goto[PushTP4];


* Typep, op 005, Replace TOS with Nil if TOS is not type number of alpha byte
@Typep:
call[lspTyp], opcode[005];* pop stack, get type in T and Type
T ← NextData[IBuf];
lu ← (lspType) - T, goto[TOSGetsNILifNeq];
* could be just lu ← NextData[IBuf] - T, goto[TOSGetsNILifNeq];

* Dtest, op 006, test if type name of TOS = arg, ufn if not
@Dtest:
call[lspTyp], opcode[006];* get type of TOS into Type
lspGenBrHi ← (DTDSpace);* point at DataTypeDescriptor table
lspGenBr ← (DTDBase);
T ← lsh[lspType, 4];* table is indexed by type
PFetch1[lspGenBr, lspType];* Type ← typename(TOS)
T ← NextData[IBuf];
lspL1 ← T;
T ← NextData[IBuf];
T ← (lsh[lspL1, 10]) or T;* T ← alpha,,beta
lu ← (lspType) - T;* is T same as typename?
lspNargs ← 2c, skip[alu#0];
NextOpCode;* Yes, return tos as is
* do ufn call inline here
StkState ← lsh[StkState, 1];* account for push
Stack&+1 ← (smallpl);* push typename atom as smallp
Stack&+1 ← T, loadpage[pgFrame];
lspDefx1 ← (atomDTESTFAIL), goto[lspCallFn0];


onpage[pgTyp];
* Subroutine to get data type of TOS, returns it in T and lspType;
* transfers TOS into L3,2 in form suitable for use as a base reg pair
lspTyp:
T ← Stack&-1;
lspL2 ← T;
T ← lsh[Stack&+1, 10];
lspL3 ← T;
T ← rsh[lspL2, 11];
T ← (rsh[lspL3, 1]) or T;
PFetch1[MDSTypeBaseBr, lspType];
T ← lspType ← rhmask[lspType], return;

* CAR, op 001, replace TOS with car[TOS]
@Car:
call[lspTyp], opcode[001];* TOS in L2, 3, type in lspType
lu ← (lspType) - (listtype);
lspUFN ← 001c, skip[alu=0];
goto[CarCdrNilP];
lspCar1:
PFetch2[lspL2, lspL0, 0];
lu ← lhmask[lspL0];
T ← rhmask[lspL0], goto[CdrTail, alu#0];
T ← lsh[lspL0, 10];* indirect cell: L3,2 ← L0,1, retry
lspL3 ← T;
T ← lspL1;
lspL2 ← T, goto[lspCar1];

* CDR, op 002, replace TOS with cdr[TOS]
@Cdr:
call[lspTyp], opcode[002];
lu ← (lspType) - (listtype);
lspUFN ← 002c, skip[alu=0];
goto[CarCdrNilP];
lspCdr3:
PFetch2[lspL2, lspL0, 0];
T ← ldf[lspL0, 1, 7], skip[R<0];* T ← cdr code
lspL2 ← (lhmask[lspL2]) + T, dblgoto[lspCdr1, lspCdr2, alu=0];
lspL2 ← (lhmask[lspL2]) + T, goto[lspCdrNil, alu=0];
T ← (lspL2) + T;* cdr is on page at offset 2*T
lspL1 ← T;
T ← rsh[lspL3, 10];
CdrTail:* Here with Hiloc[cell] in T, lo in L1
Stack&-1 ← T;
T ← lspL1, goto[PushTP4];

lspCdr1:* cdr full indirect
T ← lsh[lspL0, 10];* L3,2 ← L0,1, retry
lspL3 ← T;
T ← lspL1;
lspL2 ← T, goto[lspCdr3];

lspCdrNil:
T ← Stack&-1 ← 0c, goto[PushTP4];

lspCdr2:* cdr indirect on page: cdr is contained in cell at page + 2*cdrcode
PFetch2[lspL2, lspL0];
T ← rhmask[lspL0], goto[CdrTail];

CarCdrNilP:* Car/cdr of non-list
T ← Stack&-1;
lu ← (Stack&+1) or T;
skip[alu#0];
NextOpCode;
goto[ufnLBL];

* Bin, op 40. Takes TOS = Stream, returns byte as smallp
:IF[WithBin];
* new Bin (5 mi shorter)
@Bin:lspL6 ← (StreamType), call[lspTyp], opcode[40];
lu ← (lspL6) - T, loadpage[pgBin];* Is it a STREAM?
lspUFN ← 040c, skip[alu=0];
onpage[pgBin];
goto[ufnLBL];
PFetch4[lspL2, XBuf, 0];* Fetch first 4 words of Stream
* = Offset, NChars, Flags,,Buffer
T ← rhmask[XBuf2], skip[R<0];* Is Buffer Binable?
goto[ufnLBL];
lspL1 ← T;* lspL1 ← bufHi
lspL1 ← (lsh[lspL1, 10]) + T + 1;* convert to baseregHi
T ← XBuf1;* nbr Chars in buffer
lu ← (XBuf) - T;* Current Offset - NChars
T ← XBuf3, skip[alu<0];* Past end of buffer?
goto[ufnLBL];
lspL0 ← T, loadpage[opPage3];* L0 ← baseregLo
T ← rsh[XBuf, 1];* Get Current pos as word ptr
onpage[opPage3];
PFetch1[lspL0, lspL1];* Fetch data word
XBuf ← (XBuf) + 1, dblgoto[.+2,.+1, R odd];
* Increment position, check which byte
T ← rsh[lspL1, 10], skip;* even byte
T ← rhmask[lspL1];* odd byte
PStore4[lspL2, XBuf, 0], goto[TOSGetsTSmall];
* Store back modified OFD, push byte on stack
:ELSE;
@Bin:lspUFN ← 40c, goto[lspUfnxP4], opcode[40];
:ENDIF;
:IF[0];* old Bin
@Bin:call[lspTyp], opcode[40];
loadpage[pgBin];
lu ← (lspType) - (StreamType);* Is it a STREAM?
onpage[pgBin];
lspUFN ← 040c, skip[alu=0];
goto[ufnLBL];
PFetch4[lspL2, XBuf, 0];* Fetch first 4 words of Stream
* = Offset, NChars, Flags,,Buffer
T ← XBuf1;* nbr Chars in buffer
lu ← (XBuf) - T;* Current Position - NChars
skip[alu<0];* Past end of buffer?
goto[ufnLBL];
T ← rhmask[XBuf2], skip[R<0];* Is Buffer Readable?
goto[ufnLBL];
lspL1 ← T;
lspL1 ← (lsh[lspL1, 10]) + T + 1;
T ← XBuf3, task;
lspL0 ← T;
T ← rsh[XBuf, 1];* Get Current pos as word ptr
PFetch1[lspL0, lspL1];* Fetch data word
XBuf ← (XBuf) + 1, skip[R odd];* Increment position, check which byte
lspL1 ← rsh[lspL1, 10], skip;
nop;* Wait for XBuf to get written
PStore4[lspL2, XBuf, 0];* Store back modified OFD
Stack&-1 ← (smallpl);* Push byte as small int
T ← rhmask[lspL1];
Stack&+1 ← T, goto[nxiLBL];
:ENDIF;

RV[Case, IP[lspDefx0]];

* (RPLCONS LST ITEM) does (CDR (RPLACD LST (CONS ITEM NIL)))

:IF[WithCons];
@RplCons:
loadpage[pgHStack], call[CheckElt2P4], opcode[046];
Stack&-2, call[lspTyp];* get LST in 3,2, type in Type
loadpage[pgCons];
lu ← (lspType) - (listType);
onpage[pgCons];
lspUFN ← 46c, skip[alu=0];* set UFN for punt, skip if listp
goto[ufnLBL];* punt if LST not list

Pfetch1[lspL2, lspL4, 0];* L4 ← hiword of LST (can fault)
T ← 200c;
T ← (rsh[lspL4, 10]) xor T;* compare cdr code against cdr.nil
T ← lspL4, skip[alu=0];
goto[ufnLBL];* punt if (CDR LST) not NIL
XBuf ← T;* Save old contents for later so we can update cdr code
lspL2 ← lhmask[lspL2];* point L3,2 at LST’s page
Case ← 0c, call[MakeConsCell];* get back CONS = L3,2
* we are committed to finishing now

call[GetListpDTD];* stack points at LST now
Stack&+2, call[IncrementConsCount];* now points at ITEM

T ← Stack&-1;
lspL1 ← T;
T ← rhmask[Stack&-1];
lspL0 ← T, loadpage[pgHtFind];* ITEM in 0,1
Case ← lhmask[Case], call[GcLookup];* Addref ITEM. Preserves 2,3

T ← Stack;* loloc(LST)
lspL5 ← T;* save for below
T ← lspL2;* loloc(CONS)
Stack ← T;* Smash LST on stack (hiloc’s are same)

lspL0 ← (lspL0) or (100000c);* Put cdr.nil code in ITEM
PStore2[lspL2, lspL0, 0];* Store cdr.nil,,ITEM in CONS

T ← lsh[lspL2, 7];* 2*Offset of CONS, shifted to cdr code
XBuf ← (XBuf) or T;* insert in hi word of old LST
* (200 bit already known to be on)
T ← lspL5;* loloc(LST)
lspL2 ← T;* 2,3 now points at LST
PStore1[lspL2, XBuf, 0];* Store cdr code back to LST

loadpage[pgRplptr];
StkState ← rsh[StkState, 1], goto [GcExit];
* Account for stack decrement, go check for htpunt


@Cons:
loadpage[pgHStack], call[CheckElt2P4], opcode[032];
call[lspTyp];* get CDR in 3,2, type in Type
loadpage[pgCons];
lu ← (lspType) - (listType);
onpage[pgCons];
lspUFN ← 32c, goto[ConsList, alu=0];* set UFN for punt, do listp case
T ← lspL3, call[GetListpDTD];
lu ← (lspL2) or T;
goto[ConsNil, alu=0];
goto[ufnLBL];* cdr non-NIL non-list

ConsNil:
nop;* Even
Stack&-2, call[GetNextConsPage];* pop off cdr
Case ← 0c, call[MakeConsCell];
call[IncrementConsCount];
XBuf← 200c, goto[ConsTail];

ConsList:
lspL2 ← lhmask[lspL2];* Point at cdr’s page
Case ← 0c, call[MakeConsCell];* L2 returns pointer to Cons cell
call[GetListpDTD];
T ← Stack&-1;* Pop CDR into 0,1
lspL1 ← T, call[IncrementConsCount];
T ← Stack&-1;
lspL0 ← T;* cdr is in 0, 1
loadpage[pgHtFind];
Case ← 0c, callp[GcLookup];* Addref Cdr pointer
T ← 200c;
T ← (ldf[lspL1, 10, 7]) + T;
XBuf ← T;* cdr code

ConsTail:
T ← Stack&-1;
lspL1 ← T;
T ← Stack&+1;
lspL0 ← T, loadpage[pgHtFind];
Case ← lhmask[Case], callp[GcLookup];* Addref car pointer
T ← lsh[XBuf, 10];
lspL0 ← (rhmask[lspL0]) or T;
PStore2[lspL2, lspL0, 0];* Store cons cell
T ← rsh[lspL3, 10];* Shift hiword to normal place
Stack&-1 ← T;
lspL0 ← T;* Put ptr on stack
T ← lspL2;
Stack&+1 ← T;
lspL1 ← T, loadpage[pgHtFind];
Case ← (lhmask[Case]) + 1, callp[GcLookup];* Deleteref cons cell
loadpage[pgRplPtr];
StkState ← rsh[StkState, 1], gotop[GcExit];* Check for htoverflow

GetListpDTD:
* Set lspGenBr, BrHi to point at DTD for type LISTP
lspGenBrHi ← (DTDSpace);
lspGenBr ← (DTDBase);
lspGenBr ← (lspGenBr)+(120c), return;* 120 = Listtype lsh 4

IncrementConsCount:
* assumes lspGenBrHi,Br points at LISTPDTD

PFetch1 [lspGenBr, lspL0, 14];* old cons count from LISTPdtd
lspL0 ← (lspL0)+1;* increment count
lu ← (lspL0) - (MaxNewCellCount);* has count gotten too high?
PStore1[lspGenBr, lspL0, 14], skip[alu<0];* store updated count
Case ← (Case) or (40000c);* cause punt later
return;

GetNextConsPage:
* set L2,3 pointing at a cons page, or punt.
* smashes L0

PFetch1[lspGenBr, lspL0, 15];* get LISTPDTD:NextPage
lu ← lspL0;* No page if 0
skip[alu#0];
goto[ufnLBL];
T ← lhmask[lspL0];* form address from page#
lspL3 ← T;* hiloc of page address
T ← lsh[lspL0, 10];
lspL2 ← T, return;* loloc of page address

MakeConsCell:
* enter with L2,3 addressing desired cons page
* lspUFN = opcode that called it (for punt)
* returns L2,3 pointing at new cons cell
* smashes L0,4,5

PFetch1[lspL2, lspL0, 0];* get count, next cell
T ← rhmask[lspL0];
lspL5 ← T;* Save offset of cell
PFetch1[lspL2, lspL4];* L4 ← hiword of new cell
lspL0← (lspL0) - (400c);* subtract 1 from count
skip[alu>=0];
goto[ufnLBL];* call UFN if no cells left
T ← rsh[lspL4, 10];* offset of next free cell
lspL0← (lhmask[lspL0]) or T;
PStore1[lspL2, lspL0, 0];* Store count, next cell
T ← lspL5;* word# in page of new cell

lspL2 ← (lspL2) or T, return;* Create ptr to new cell

:ELSE;
@RplCons:
lspUFN ← 46c, goto[lspUfnxP4], opcode[46];
@Cons:lspUFN ← 32c, goto[lspUfnxP4], opcode[32];
:ENDIF;


* CreateCell[type] -> Cell. No change to stack state

:IF[WithCreateCell];
@CreateCell:
T ← lsh[Stack&-1, 4], call[XCreateCell], opcode[37];
loadpage[pgRplPtr];
gotop[GcExit];

XCreateCell:
lu ← (Stack&+1) xor (smallpl);* Punt if type not smallp
qBuf ← T, UseCTask, goto[DoCreateCella, alu=0];
lspUFN ← 37c, goto[ufnLBL];

* CreateCell subroutine. Enter with qBuf = lsh[type#,4].
* Returns with TOS replaced by new cell, whose base address is in lspGenBr.
* Caller must finish by going to GcExit.

onpage[opPage0];

DoCreateCell:
UseCTask;
DoCreateCella:
T ← APC&APCTask;
lspL6 ← T;* Save return address
qBuf1 ← (DTDSpace);* form basereg for DTD
qBuf ← (qBuf) + (DTDBase);* finish forming basereg
PFetch4[qBuf, uBuf, 0], call[retLBL];* Fetch out of DTD for this type:
* uBuf = name (not used)
* uBuf1 = Size in words
* uBuf2,3 = FREE
* cannot fault?
PFetch1[qBuf, lspL4, 14];* L4 ← DTD:COUNTER
T ← rhmask[uBuf2];* FreeHi
lu ← (uBuf3) or T, loadpage[pgCreateCell];* test that free # nil
lspL0 ← T, goto[CreateNIL, alu=0];* need Hi here for Gcref
onpage[pgCreateCell];
T ← (lsh[uBuf2, 10]) + T + 1;* form basereghi
lspGenBrHi ← T;
T ← uBuf3;* FreeLo
lspGenBr ← T;* here for addressing
lspL1 ← T;* here for Gc
PFetch2[lspGenBr, uBuf2, 0];* get old contents of FREE = new FREE
* can fault
xBuf ← 0c;
xBuf1 ← 0c;* Prepare for clearing...
T ← uBuf1, call[CreateDec];* point at end of region for clearing, top down

CreateLp:
PStore2[lspGenBr, xBuf];* Clear two words; can fault
CreateDec:
T ← (Form-2[AllOnes]) + T;* T ← T-2
skip[alu<0];
return;* to CreateLp

* no more faults possible now
:IF[IFE[pgHtFind, pgCreateCell, 0, 1]];
loadpage[pgHtFind];
:ENDIF;
Case ← 1c, callp[GcLookup];* Deleteref new cell
PStore4[qBuf, uBuf, 0];* Store back new FREE and old friends
lspL4 ← (lspL4) + 1;* increment counter
T ← rhmask[uBuf2];
lu ← (uBuf3) or T;* Check new FREE = NIL
lu ← (lspL4) - (MaxNewCellCount), skip[alu#0];* increment counter
Case ← (Case) or (CreateCellPunt);* Punt later if freelist empty
T ← lspL0, skip[alu<0];
Case ← (Case) or (CreateCellPunt);* Punt later if counter too high
Stack&-1 ← T;* TOS ← new cell
PStore1[qBuf, lspL4, 14];* Store counter back
T ← lspL1;
Stack&+1 ← T;
APC&APCTask ← lspL6, goto[retLBL];

CreateNIL:* Freelist is empty, so need to punt,
* but lspUFN is not set. Assume only
* one-byte opcodes call us
T ← (PCXReg) - 1;* back up PCF
lspUFN ← T;
PCF ← lspUFN, call[retLBL];* wait for it to write
T ← NextData[IBuf];* reread current instruction
lspUFN ← T, goto[ufnLBL];

:ELSE;
@CreateCell:
lspUfn ← 37c, goto[lspUfnxP4], opcode[37];
:ENDIF;

:END[Ops];