opsubs.p

<B>Digital的Unix操作系统VAX 4.2源码</B>

procedure opcupc;
begin
	CallProcOp(opcup);
end;

procedure opdecc;
begin
    if opdcount<>2 then error(9);
    Increment(-Int(opd^[2]));
end;

procedure opdefc;
var nump, numt, numm : integer;
    rbit, i : integer;
    r : Reg;
    defblk : integer;
begin
	{ define offsets for activation record
	    offsets are negative from fp
	    first two words are for the old display and the current ap
	 *  tNNN = -8-numt*4		offset of generally temporaries
	 *  mNNN = tNNN-numm*4		offset of most local variables
	 *  pNNN = 4			skip count word at start of list
	 *  vNNN = save mask for registers used as T storage
	 The following have been moved to opexic so def can be earlier
	 *  sNNN = mNNN-stackMemSize*4	offset of pcode translator temporaries
	 *  aNNN = -sNNN		total activation record size
	 }
	if opdcount<>5 then error(9);
	nump := Int(opd^[1]);
	numt := Int(opd^[2]);
	numm := Int(opd^[3]);
	defblk := Int(opd^[4]);
	if defblk <> curblockid then begin
	    Error('Unexpected block on def');
	end;
	tmemoff := -8 - numt*4;
	mmemoff := tmemoff - numm*4;
	pmemoff := 4;
	{ discourage use of these before they are defined }
	smemoff := -maxint-1;
	arsize := -maxint-1;
	regmask := 0;
	rbit := 1;
	for r := r1 to firsttreg do begin
	    rbit := rbit * 2;
	end;
	for i := 1 to maxtoffset div WORDSIZE do begin
	    if i <= numt then begin
		regmask := regmask + rbit;
	    end;
	    rbit := rbit * 2;
	end;
	Op('.set'); C('t'); I(defblk); X; I(tmemoff); L;
	Op('.set'); C('m'); I(defblk); X; I(mmemoff); L;
	Op('.set'); C('p'); I(defblk); X; I(pmemoff); L;
end;

procedure opexic;
begin
	{ define offsets for activation record
	    see opdefc for explanation
	}
	smemoff := mmemoff - 4*stackMemSize;
	arsize := -smemoff;
	Op('.set'); C('s'); I(curblockid); X; I(smemoff); L;
	Op('.set'); C('a'); I(curblockid); X; I(arsize); L;
	Op('.set'); C('v'); I(curblockid); X; I(regmask); L;
end;

procedure opdifc;
var
    wordsize : sizerange;
begin
    check2(2,[tset]);

    if ees[top].size <= WORDSIZE then begin
	TwoOrThree('biclN',top,top-1,tset,WORDSIZE);
    end else begin
	wordsize := (ees[top].size + WORDSIZE-1) div WORDSIZE;
	Eval(top-1);
	Push(EESDATA);
	ees[top].ptype := tinteger;
	ees[top].size := WORDSIZE;
	ees[top].constInt := wordsize;
	MultiWordBinOp('bicl2',top-1,top-2);
    end;
    Pop(1);
end;

procedure opdivc;
var
    k : integer;
begin
    if opd11 = 'r' then begin
	TwoOrThree('divfN',top,top-1,treal,WORDSIZE);
	Pop(1);
    end else if opd11 = 'R' then begin
	TwoOrThree('divdN',top,top-1,tlongreal,2*WORDSIZE);
	Pop(1);
    end else if opd11 = 'j' then begin
	if (ees[top].kind = EESDATA) and (ees[top].dreg = NULLREG) then begin
	    { divide by constant }
	    if ees[top].constInt = 1 then begin
		{ do nothing }
		Pop(1);
	    end else begin
		k := PowerOfTwo(ees[top].constInt);
		if k > 0 then begin
		    Eval(top-1);
		    { first clear low order bits that will be rotated around }
		    { (because value is a power of 2, value-1 is correct mask) }
		    Op('bicl2'); C('$'); I(ees[top].constInt-1); X;
				    Opnd(top-1); L;
		    Op('rotl'); C('$'); I(-k); X; Opnd(top-1); X;
			Opnd(top-1); L;
		    Pop(1);
		end else begin
		    CallProc(opcep,'i',WORDSIZE,2,RTLONGDIV);
		end;
	    end;
	end else begin
	    CallProc(opcep,'i',WORDSIZE,2,RTLONGDIV);
	end;
    end else begin
	TwoOrThree('divlN',top,top-1,tinteger,WORDSIZE);
	Pop(1);
    end;
end;

procedure opdv2c;
begin
    error(6);
end;

procedure opdspc;
var size : integer;
begin
    if (ees[top].ptype<>tinteger) then error(2);
    if (opdcount<>1) then error(9);
    if ees[top-1].ptype<>taddress then error(4);

    size := (Int(opd^[1]) + WORDSIZE-1) div WORDSIZE;
    if (size <> WORDSIZE) and (size <> BYTESIZE) then begin
	Error('opmp2: bad size');
    end;
    if (ees[top].kind = EESDATA) and (ees[top].dreg = NULLREG) then begin
	{ constant size }
	ees[top].constInt := ees[top].constInt * size;
    end else begin
	{ compute size }
	Eval(top);
	Op('mull2'); C('$'); I(size); X; Opnd(top); L;
    end;
    CallProc(opcep,'p',0,2,RTDISPOSE);
end;

{
    Note: there are two kinds of linkage -- external (CALLS) and internal (JSB)
    The following shows what a stack frame looks like on internal call
    Attempts are made to make the stack frame look like CALLS frame for
	debugging purposes.
    
		Param 3  parameters		^
		Param 2				| higher addresses are up    |
		Param 1					    stack grows down V
	ap ->	Return address	(occupies parameter count position)
		Saved old fp
		Saved old ap
		Unused (occupies CALLS save mask position)
	fp ->	Unused (occupies CALLS condition handler pointer position)
		Saved new ap (for use in display)
		Saved old display register 
		T Memory	\
		M Memory	|- activation record
		 etc.		/
	sp1 ->	Last word of activation record
		Saved regs r11-r6 if necessary
	sp2 ->	Last saved reg
		Dynamic area for large value parameters
	sp3 ->	Last word of dynamic area

    Note:  sp will be left pointing at either sp1, sp2, or sp3 depending on
	whether or not there are any saved regs or dynamic area.
    
    For completeness, here is how CALLS leaves the stack (notice the family
	resemblance with the above)
		Param 3  parameters		^
		Param 2				| higher addresses are up    |
		Param 1					    stack grows down V
	ap ->	Number of parameter words
		Saved regs r11-r6 if necessary
		Return address
		Saved old fp
		Saved old ap
		Saved register bits and interrupt mask
	fp ->	Condition handler pointer
		Saved new ap (for use in display)
		Saved old display register 
		T Memory	\
		M Memory	|- activation record
		 etc.		/
	sp1 ->	Last word of activation record
		Dynamic area for large value parameters
	sp3 ->	Last word of dynamic area

    With CALLS, there won't be any registers saved down here.
}
procedure opentc;
const
    STABLINE = 68;
var i, j, parmcnt, linenum, lab : integer;
    r : Reg;
    gprof : boolean;
begin
    if (opdcount<6) then error(9);
    if (pclbsize=0) then error(19);

    curlev := Int(opd^[3]);
    curblockid := Int(opd^[4]);
    parmcnt := Int(opd^[5]);
    linenum := Int(opd^[6]);
    if opdcount >= 7 then begin
	nodisplay := opd^[7][1] = '1';
	internal := opd^[7][2] = '1';
	gprof := opd^[7][3] = '1';
    end else begin
	nodisplay := false;
	internal := false;
	gprof := false;
    end;
    maxtoffset := -1;
    lastreg := LASTREG;
    firsttreg := NULLREG;
    if opdcount >= 8 then begin
	i := Int(opd^[8]);
	if i > 6 then begin
	    i := 6;
	end;
	if i > 0 then begin
	    maxtoffset := i * WORDSIZE;
	    lastreg := LASTREG;
	    for j := 1 to i do begin
		lastreg := pred(lastreg);
	    end;
	    firsttreg := succ(lastreg);
	end;
    end;
    if (curlev>MAXDISPLEVEL) then Error('opent: display level to large');
    ClearStack;
    if PRINTNAMES then begin
	Op('.data'); I(1); L;
	S('name'); I(curblockid); C(':'); Op('.asciz');
		C('"'); SO(pclabel); C('"'); L;
	Op('.text'); L;
    end;
    Op('.align'); I(2); L;
    Op('.globl'); C('_'); SO(pclabel); L;
    C('_'); SO(pclabel); C(':'); L;
    if not internal then begin
	Op('.word'); C('v'); I(curblockid); L;
    end else begin
	{ internal entry sequence }
	Op('movl'); R(fp); X; S('-4(sp)'); L;
	Op('movl'); R(ap); X; S('-8(sp)'); L;
	Op('movl'); R(sp); X; R(ap); L;
	Op('movab'); S('-16(sp)'); X; R(fp); L;
    end;
    if linenum <> 0 then begin
	Op('.stabd'); I(STABLINE); X; I(0); X; I(linenum); L;
    end;
    if (curblockid = mainprogblockid) then begin
	    { Push argv and argc for modelinit (to pass to readcore }
	    Op('pushl'); S('12(ap)'); L;
	    Op('pushl'); S('8(ap)'); L;
	    Op('pushl'); S('4(ap)'); L;
	    Op('calls'); S('$3,_runtime__init'); L;
    end;
    if not nodisplay then begin
	{ save ap and old display }
	Op('movl'); R(ap); X; I(APOFF); S('(fp)'); L;
	Op('movl'); S('_runtime__display+'); I(curlev*4); X;
			I(DISPOFF); S('(fp)'); L;
	{ set up new display }
	Op('movl'); R(fp); X; S('_runtime__display+'); I(curlev*4); L;
    end;
    { allocate activation record }
    Op('subl3'); S('$a'); I(curblockid); X; R(fp); X; R(sp); L;
    if internal then begin
	if firsttreg <> NULLREG then begin
	    for r := firsttreg to LASTREG do begin
		Op('pushl'); R(r); L;
	    end;
	end;
    end;
    if PRINTNAMES then begin
	Op('pushal'); S('name'); I(curblockid); L;
	Op('calls'); S('$1'); X; S('_runtime__trace'); L;
    end;
    if gprof then begin
	lab := NewLabel;
	Op('movab'); Lab(lab); X; R(r0); L;
	Op('jsb'); S('mcount'); L;
	Op('.data'); L;
	Op('.align'); I(2); L;
	Lab(lab); C(':'); Op('.long'); I(0); L;
	Op('.text'); L;
    end;
    ClearReg;
end;

procedure opequc;
begin
    Compare(associatedType[opd11],Int(opd^[2]));
    nextjump := jceq;       { set up to do eq jump }
end;

procedure opfjpc;
begin
    if (ees[top].ptype<>tboolean) then error(2);
    if (opdcount<>1) then error(9);

    Check(top,BOOLSIZE);
    Op('bitb'); S('$1'); X; Opnd(top); L;
    Op('jeql'); writelabel(1); L;
    Pop(1);
end;

procedure opfltc;
var
    r : Reg;
    op : ShortString;
begin
    if not (ees[top].ptype in [tinteger, tcardinal, treal, tlongreal])
	then error(2);
    Check(top,WORDSIZE);
    if opd11 = 'r' then begin
	if ees[top].ptype in [tinteger,tcardinal] then begin
	    op := 'cvtlf';
	end else if ees[top].ptype in [treal,tlongreal] then begin
	    op := 'movl';	{ real - no op, long real - ignore second word }
	end else begin
	    Error('opfltc: unexpected type');
	end;
	if (ees[top].kind = EESDATA) and (ees[top].dreg <> NULLREG) then begin
	    Op(op); Opnd(top); X; Opnd(top); L;
	end else begin
	    r := AllocReg(REGEES,top,treal);
	    Op(op); Opnd(top); X; R(r); L;
	    ees[top].kind := EESDATA;
	    ClearAddress(top);
	    FreeReg(ees[top].dreg);
	    ees[top].dreg := r;
	end;
	ees[top].ptype := treal;
	ees[top].size := WORDSIZE;
    end else if opd11 = 'R' then begin
	if ees[top].ptype in [tinteger,tcardinal] then begin
	    op := 'cvtld';
	end else if ees[top].ptype = treal then begin
	    op := 'cvtfd';
	end else begin
	    op := 'movd';	{ longreal - no op }
	end;
	r := AllocReg(REGEES,top,tlongreal);
	Op(op); Opnd(top); X; R(r); L;
	ees[top].kind := EESDATA;
	ClearAddress(top);
	ees[top].ptype := tlongreal;
	ees[top].size := 2*WORDSIZE;
	FreeReg(ees[top].dreg);
	ees[top].dreg := r;
    end else begin
	Error('opfltc: not r or R');
    end;
end;

procedure opgeqc;
begin
    Compare(associatedType[opd11],Int(opd^[2]));
    if opd11 in ['c','j'] then begin
	nextjump := jcgeu;	{ set up to do geu jump }
    end else begin
	nextjump := jcge;	{ set up to do ge jump }
    end;
end;

procedure opgrtc;
begin
    Compare(associatedType[opd11],Int(opd^[2]));
    if opd11 in ['c','j'] then begin
	nextjump := jcgtu;	{ set up to do gtu jump }
    end else begin
	nextjump := jcgt;	{ set up to do gt jump }
    end;
end;

procedure opincc;
begin
	if opdcount<>2 then error(9);
	Increment(Int(opd^[2]));
end;

procedure opindc;
begin
    MakeVariable(top);
    ees[top].ptype := associatedType[opd11];
    ees[top].size := Int(opd^[2]);
end;

procedure opinnc;
var
    r : Reg;
    lab : LabelNumber;
    i, mask : integer;
begin
    if (ees[top].ptype<>tset) then error(2);
    if not (ees[top-1].ptype in [tinteger,tcardinal,tchar]) then begin
	error(4);
    end;

    if (ees[top-1].kind = EESDATA) and (ees[top-1].dreg = NULLREG)
	    and (ees[top].size <= WORDSIZE)
    then begin
	{ element is constant, set is word }
	{ subtract set from set containing only element }
	{ result is 0 if set contains element }
	mask := 1;
	for i := 1 to ees[top-1].constInt do begin
	    mask := Mult(mask,2);
	end;
	r := AllocReg(REGTEMP,0,tset);
	if ees[top].size = BYTESIZE then begin
	    Check(top,BYTESIZE);
	    Op('bicb3'); Opnd(top); X; C('$'); I(mask); X; R(r); L;
	end else begin
	    Check(top,WORDSIZE);
	    Op('bicl3'); Opnd(top); X; C('$'); I(mask); X; R(r); L;
	end;
	FreeReg(r);
	nextjump := jceq;       { set up to do eq jump }
	Pop(2);
    end else begin
	Check(top-1,WORDSIZE);
	lab := NewLabel;
	r := AllocReg(REGEES,top-1,tboolean);
	if (ees[top-1].kind = EESDATA) and (ees[top-1].dreg = NULLREG)
		and (ees[top-1].constInt < ees[top].size)
	then begin
	    { no test necessary }
	end else begin
	    Op('clrl'); R(r); L;
	    Op('cmpl'); Opnd(top-1); X; C('$'); I(ees[top].size); L;
	    Op('jgequ'); Lab(lab); L;
	end;
	if ees[top].size > WORDSIZE then begin
	    Point(top); { instruction requires address }
	end else if (ees[top].kind = EESDATA) and (ees[top].dreg = NULLREG)
	then begin
	    Eval(top);	{ constant doesn't work in this instruction }
	end else begin
	    Check(top,WORDSIZE);
	    CheckRegs(top,BYTESIZE);	{ instruction requires byte index }
	end;
	Op('extzv'); Opnd(top-1); X; S('$1'); X; Opnd(top); X; R(r); L;
	Lab(lab); C(':'); L;
	Pop(2);
	Push(EESDATA);
	ees[top].ptype := tboolean;
	ees[top].size := BOOLSIZE;
	ees[top].dreg := r;
    end;
end;

procedure opintc;
var
    wordsize : sizerange;
begin
    check2(2,[tset]);

    if ees[top].size <= WORDSIZE then begin
	Eval(top);
	Op('mcoml'); Opnd(top); X; Opnd(top); L;
	TwoOrThree('biclN',top,top-1,tset,WORDSIZE);
    end else begin
	wordsize := (ees[top].size + WORDSIZE-1) div WORDSIZE;
	Eval(top);
	Push(EESDATA);
	ees[top].ptype := tinteger;
	ees[top].size := WORDSIZE;
	ees[top].constInt := wordsize;
	MultiWordBinOp('mcoml',top-1,top-1);
	Eval(top-1);
	Push(EESDATA);
	ees[top].ptype := tinteger;
	ees[top].size := WORDSIZE;
	ees[top].constInt := wordsize;