reduce-historical/psl-1983/20-comp/dec20-lap.red

%
% 20-LAP.RED - Dec-20 PSL assembler
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        1 February 1982
% Copyright (c) 1982 University of Utah
%

fluid '(LabelOffsets!* CurrentOffset!* CodeSize!* CodeBase!* Entries!*
	ForwardInternalReferences!*
	NewBitTableEntry!* LapReturnValue!*
	!*WritingFaslFile InitOffset!* !*PGWD !*PWrds);

CompileTime <<

flag('(SaveEntry DefineEntries DepositInstruction
       OpcodeValue OperandValue DepositWord DepositWordExpression
       DepositHalfWords LabelValue DepositItem DepositHalfWordIDNumber
       FindLabels OneLapLength MakeRelocInf MakeRelocWord),
     'InternalFunction);

smacro procedure LabelP X;
    atom X;

>>;

LoadTime <<

!*PWrds := T;

>>;

lisp procedure Lap U;
begin scalar LapReturnValue!*, LabelOffsets!*, Entries!*;
    if not !*WritingFaslFile then
	CurrentOffset!* := 0;
    U := Pass1Lap U;
    FindLabels U;
    if !*PGWD then for each X in U do
	if atom X then Prin2 X else PrintF("		%p%n", X);
    if not !*WritingFaslFile then
	CodeBase!* := GTBPS CodeSize!*;
    for each X in U do
	if not LabelP X then
	    if first X = '!*entry then SaveEntry X
	    else DepositInstruction X;
    DefineEntries();
    if not !*WritingFaslFile and !*PWrds then
	ErrorPrintF("*** %p: base %o, length %d words",
		for each X in Entries!* collect first car X,
				CodeBase!*, CodeSize!*);
    return MkCODE LapReturnValue!*;
end;

lisp procedure SaveEntry X;
    if second X = '!*!*!*Code!*!*Pointer!*!*!* then
	LapReturnValue!* :=		% Magic token that tells LAP to return
	    (if !*WritingFaslFile then CurrentOffset!*	%  a code pointer
		else IPlus2(CodeBase!*, CurrentOffset!*))
    else if not !*WritingFaslFile then
    <<  Entries!* := (rest X . CurrentOffset!*) . Entries!*;
	if not LapReturnValue!* then LapReturnValue!* :=
	    IPlus2(CodeBase!*, CurrentOffset!*) >>
    else if second X = '!*!*Fasl!*!*InitCode!*!* then
	InitOffset!* := CurrentOffset!*
    else if FlagP(second X, 'InternalFunction) then
	put(second X, 'InternalEntryOffset, CurrentOffset!*)
    else
    <<  FindIDNumber second X;
	DFPrintFasl list('PutEntry, MkQuote second X,
				    MkQuote third X,
				    CurrentOffset!*) >>;

lisp procedure DefineEntries();
    for each X in Entries!* do
	PutD(first car X, second car X, MkCODE IPlus2(CodeBase!*, cdr X));

lisp procedure DepositInstruction X;
%
% Legal forms are:
%  (special_form . any)
%  (opcode)
%  (opcode address)
%  (opcode ac address)
%
begin scalar Op, Y, A, E;
    return if (Y := get(first X, 'InstructionDepositFunction)) then
	Apply(Y, list X)
    else
    <<  NewBitTableEntry!* := 0;
	Op := OpcodeValue first X;
	if null(Y := rest X) then
	    A := E := 0
	else
	<<  E := OperandValue first Y;
	    if null(Y := rest Y) then
		A := 0
	    else
	    <<  A := E;
		E := OperandValue first Y >> >>;
	UpdateBitTable(1, NewBitTableEntry!*);
	DepositAllFields(Op, A, E) >>;
end;

lisp procedure DepositAllFields(Op, A, E);
<<  @IPlus2(CodeBase!*, CurrentOffset!*) :=
	ILOR(ILSH(Op, 27), ILOR(ILSH(A, 23), E));
    CurrentOffset!* := IAdd1 CurrentOffset!* >>;

lisp procedure OpcodeValue U;
    if PosIntP U then U
    else get(U, 'OpcodeValue) or StdError BldMsg("Unknown opcode %r", U);

lisp procedure OperandValue U;
%
% Legal forms are:
% number
% other atom (label)
% (special . any)	fluid, global, etc.
% (indexed register address)
% (indirect other_op)
%
begin scalar X;
    return if PosIntP U then U
    else if NegIntP U then ILAND(U, 8#777777)
    else if LabelP U then LabelValue U
    else if (X := get(first U, 'OperandValueFunction)) then
	Apply(X, list U)
    else if (X := WConstEvaluable U) then OperandValue X
    else StdError BldMsg("Unknown operand %r", U);
end;

lisp procedure BinaryOperand U;
%
% (op x x) can occur in expressions
%
begin scalar X;
    return if (X := WConstEvaluable U) then X
    else
    <<  X := if GetD first U then first U else get(first U, 'DOFN);
	U := rest U;
	if NumberP first U then
	    Apply(X, list(first U, LabelValue second U))
	else if NumberP second U then
	    Apply(X, list(LabelValue first U, second U))
	else StdError BldMsg("Expression too complicated in LAP %r", U) >>;
end;

% Add others to this list if they arise

put('difference, 'OperandValueFunction, 'BinaryOperand);
put('WPlus2, 'OperandValueFunction, 'BinaryOperand);

lisp procedure RegisterOperand U;
begin scalar V;
    U := second U;
    return if PosIntP U then U
    else if (V := get(U, 'RegisterNumber)) then V
    else StdError BldMsg("Unknown register %r", U);
end;

put('REG, 'OperandValueFunction, 'RegisterOperand);

DefList('((nil 0)
	  (t1 6)
	  (t2 7)
	  (t3 8)
	  (t4 9)
	  (t5 10)
	  (t6 11)
	  (st 8#17)), 'RegisterNumber);

lisp procedure ImmediateOperand U;
    OperandValue second U;		% immediate does nothing on the PDP10

put('immediate, 'OperandValueFunction, 'ImmediateOperand);

lisp procedure IndexedOperand U;
begin scalar V;
    V := OperandValue second U;
    U := OperandValue third U;
    return ILOR(ILSH(V, 18), U);
end;

put('indexed, 'OperandValueFunction, 'IndexedOperand);

lisp procedure LapValueCell U;
    ValueCellLocation second U;

DefList('((fluid LapValueCell)
	  (!$fluid LapValueCell)
	  (global LapValueCell)
	  (!$global LapValueCell)), 'OperandValueFunction);

lisp procedure LapEntry U;
    FunctionCellLocation second U;

put('entry, 'OperandValueFunction, 'LapEntry);

lisp procedure LapInternalEntry U;
begin scalar X;
    U := second U;
    NewBitTableEntry!* := const RELOC_HALFWORD;
    return if (X := Atsoc(U, LabelOffsets!*)) then
    <<  X := cdr X;
	if !*WritingFaslFile then X else IPlus2(CodeBase!*, X) >>
    else
    <<  if not !*WritingFaslFile then FunctionCellLocation U
	else if (X := get(U, 'InternalEntryOffset)) then X
	else
	<<  ForwardInternalReferences!* :=
		   (CurrentOffset!* . U) . ForwardInternalReferences!*;
	    0 >> >>;			% will be modified later
end;

put('InternalEntry, 'OperandValueFunction, 'LapInternalEntry);

lisp procedure DepositWordBlock X;
    for each Y in cdr X do DepositWordExpression Y;

put('fullword, 'InstructionDepositFunction, 'DepositWordBlock);

lisp procedure DepositHalfWordBlock X;
begin scalar L, R;
    X := rest X;
    while not null X do
    <<  L := first X;
	X := rest X;
	if null X then
	   R := 0
	else
	<<  R := first X;
	    X := rest X >>;
	DepositHalfWords(L, R) >>;
end;

put('halfword, 'InstructionDepositFunction, 'DepositHalfWordBlock);

CommentOutCode <<
lisp procedure DepositByteBlock X;
    case length X of
    0: DepositWord 0;
    1: DepositBytes(first X, 0, 0, 0, 0);
    2: DepositBytes(first X, second X, 0, 0, 0);
    3: DepositBytes(first X, second X, third X, 0, 0);
    4: DepositBytes(first X, second X, third X, fourth X, 0);
    default:
    <<  DepositBytes(first X, second X, third X, fourth X, fourth rest X);
	DepositByteBlock rest rest rest rest rest X >>;
    end;

put('byte, 'InstructionDepositFunction, 'DepositByteBlock);
>>;

lisp procedure DepositString X;
begin scalar Y;
    X := StrInf second X;
    Y := StrPack StrLen X;
    for I := 1 step 1 until Y do DepositWord @IPlus2(X, I);
end;

put('string, 'InstructionDepositFunction, 'DepositString);

lisp procedure DepositFloat X;		% this will not work in cross-assembly
<<  X := second X;			% don't need to strip tag on PDP10
    DepositWord FloatHighOrder X;
    DepositWord FloatLowOrder X >>;

put('float, 'InstructionDepositFunction, 'DepositFloat);

lisp procedure DepositWord X;
<<  @IPlus2(CodeBase!*, CurrentOffset!*) := X;
    UpdateBitTable(1, 0);
    CurrentOffset!* := IAdd1 CurrentOffset!* >>;

lisp procedure DepositWordExpression X;	% Only limited expressions now handled
begin scalar Y;
    return if FixP X then DepositWord Int2Sys X
    else if LabelP X then
    <<  @IPlus2(CodeBase!*, CurrentOffset!*) := LabelValue X;
	UpdateBitTable(1, const RELOC_HALFWORD);
	CurrentOffset!* := IAdd1 CurrentOffset!* >>
    else if first X = 'MkItem then DepositItem(second X, third X)
    else if first X = 'FieldPointer then
	DepositFieldPointer(second X, third X, fourth X)
    else if (Y := WConstEvaluable X) then DepositWord Int2Sys Y
    else StdError BldMsg("Expression too complicated %r", X);
end;

lisp procedure DepositHalfWords(L, R);
begin scalar Y;
    if not (FixP L or (L := WConstEvaluable L))
	then StdError "Left half too complex";
    if PairP R and first R = 'IDLoc then
	DepositHalfWordIDNumber(L, second R)
    else if (Y := WConstEvaluable R) then DepositWord ILOR(ILSH(L, 18), Y)
    else StdError BldMsg("Halfword expression too complicated %r", R);
end;

lisp procedure LabelValue U;
begin scalar V;
    return if CodeP U then Inf U
    else if (V := Atsoc(U, LabelOffsets!*)) then
    <<  V := cdr V;
	if !*WritingFaslFile then
	<<  NewBitTableEntry!* := const RELOC_HALFWORD;
	    V >>
	else IPlus2(CodeBase!*, V) >>
    else StdError BldMsg("Unknown label %r in LAP", U);
end;

lisp procedure DepositItem(TagPart, InfPart);
    if not !*WritingFaslFile then
    DepositWord MkItem(TagPart, if LabelP InfPart then
				    LabelValue InfPart
				else if first InfPart = 'IDLoc then
				    IDInf second InfPart
				else
				    StdError BldMsg("Unknown inf in MkItem %r",
								     InfPart))
    else
    <<  if LabelP InfPart then
	    @IPlus2(CodeBase!*, CurrentOffset!*) :=	% RELOC_CODE_OFFSET = 0
				MkItem(TagPart, LabelValue InfPart)
	else if first InfPart = 'IDLoc then
	    @IPlus2(CodeBase!*, CurrentOffset!*) :=
			MkItem(TagPart,
			       MakeRelocInf(const RELOC_ID_NUMBER,
					    FindIDNumber second InfPart))
	else StdError BldMsg("Unknown inf in MkItem %r", InfPart);
	CurrentOffset!* := IAdd1 CurrentOffset!*;
	UpdateBitTable(1, const RELOC_INF) >>;

lisp procedure DepositHalfWordIDNumber(LHS, X);
    if not !*WritingFaslFile or ILEQ(IDInf X, 128) then
	DepositWord ILOR(ILSH(LHS, 18), IDInf X)
    else
    <<  @IPlus2(CodeBase!*, CurrentOffset!*) := ILOR(ILSH(LHS, 18),
		MakeRelocHalfWord(const RELOC_ID_NUMBER, FindIDNumber X));
	CurrentOffset!* := IAdd1 CurrentOffset!*;
	UpdateBitTable(1, const RELOC_HALFWORD) >>;

lisp procedure SystemFaslFixup();
<<  while not null ForwardInternalReferences!* do
    <<  Field(@IPlus2(CodeBase!*,
		      car first ForwardInternalReferences!*),
	      18, 18) :=
	    get(cdr first ForwardInternalReferences!*, 'InternalEntryOffset)
		or <<  ErrorPrintF(
"***** %r not defined in this module; normal function call being used",
	cdr first ForwardInternalReferences!*);
		MakeRelocHalfWord(const RELOC_FUNCTION_CELL,
				  FindIDNumber cdr first
					ForwardInternalReferences!*) >>;
	ForwardInternalReferences!* := cdr ForwardInternalReferences!* >>;
    MapObl function lambda(X);
	RemProp(X, 'InternalEntryOffset) >>;
			

fluid '(LapCodeList!*);

lisp procedure FindLabels LapCodeList!*;
<<  CodeSize!* := 0;
    for each X in LapCodeList!* do
	CodeSize!* := IPlus2(CodeSize!*, OneLapLength X) >>;

lisp procedure OneLapLength U;
begin scalar X;
    return if atom U then
    <<  LabelOffsets!* := (U . IPlus2(CurrentOffset!*, CodeSize!*))
				. LabelOffsets!*;
	0 >>
    else if (X := get(car U, 'LapLength)) then
	if PosIntP X then X
	else Apply(X, list U)
    else				% minor klugde for long constants
    <<  if length U = 3 and FixP(X := third U) and not ImmediateP X then
	begin scalar Y;
	    RPlaca(rest rest U, Y := StringGensym());
	    NConc(LapCodeList!*, list(Y, list('fullword, X)));
	end;
    1 >>;
end;

DefList('((!*entry LapEntryLength)
	  (float 2)
	  (string LapStringLength)
	  (fullword LapWordLength)
	  (halfword LapHalfwordLength)
	  (byte LapByteLength)), 'LapLength);

lisp procedure LapEntryLength U;
<<  LabelOffsets!* := (second U . IPlus2(CurrentOffset!*, CodeSize!*))
			. LabelOffsets!*;
    0 >>;

lisp procedure LapStringLength U;
    StrPack StrLen StrInf second U;

lisp procedure LapWordLength U;
    length rest U;

lisp procedure LapHalfwordLength U;
    ILSH(IAdd1 length rest U, -1);

lisp procedure LapByteLength U;
    StrPack length rest U;

on SysLisp;

syslsp procedure DepositFieldPointer(Opr, Start, Len);
<<  LispVar NewBitTableEntry!* := 0;
    Opr := OperandValue Opr;
    @IPlus2(LispVar CodeBase!*, LispVar CurrentOffset!*) :=
	ILOR(ILSH(36 - (Start + Len), 30), ILOR(ILSH(Len, 24), Opr));
    UpdateBitTable(1, LispVar NewBitTableEntry!*);
    LispVar CurrentOffset!* := IAdd1 LispVar CurrentOffset!* >>;

syslsp procedure IndirectOperand U;
    ILOR(ILSH(1, 22), OperandValue second U);

put('Indirect, 'OperandValueFunction, 'IndirectOperand);

% ExtraRegLocation is in 20-FASL

put('ExtraReg, 'OperandValueFunction, 'ExtraRegLocation);

syslsp procedure MakeRelocWord(RelocTag, RelocInf);
    LSH(RelocTag, 34) + Field(RelocInf, 2, 34);

syslsp procedure MakeRelocInf(RelocTag, RelocInf);
    LSH(RelocTag, 16) + Field(RelocInf, 20, 16);

syslsp procedure MakeRelocHalfWord(RelocTag, RelocInf);
    LSH(RelocTag, 16) + Field(RelocInf, 20, 16);

off SysLisp;

END;