-- BBApplyImpl.mesa
-- Russ Atkinson, February 24, 1983 1:14 pm

DIRECTORY
AMBridge USING
[FHFromTV, GFHFromTV, IsRemote, Loophole, RemotePointer,
SetTVFromLC, SetTVFromLI, SomeRefFromTV, TVForPointerReferent,
TVForReadOnlyReferent, TVForReferent, TVForRemotePointerReferent,
TVToCardinal, TVToInteger, TVToLC, TVToLI, TVToProc],
AMEvents USING [Apply],
AMTypes USING
[Argument, Assign, Class, Coerce, Copy, Domain, Error, GroundStar,
IndexToTV, NComponents, New, Procedure,
Range, Signal, Size, TVSize, TVType, TypeClass, UnderType],
BBApply USING [],
BBZones USING [GetPrefixedZone],
Mopcodes USING [zALLOC, zFREE, zLADRB],
PrincOps USING
[ControlLink, FrameHandle, FrameVec, GlobalFrameHandle, LastAVSlot,
MaxParamsInStack, ProcDesc, stackDepth, StateVector],
Rope USING [ROPE],
RTBasic USING [nullType, TV, Type],
RTTypesBasic USING [EquivalentTypes, GetReferentType, refAnyType],
WorldVM USING [Address, CurrentIncarnation, LocalWorld, World];

BBApplyImpl: CEDAR MONITOR
IMPORTS AMBridge, AMEvents, AMTypes, BBZones, RTTypesBasic, WorldVM
EXPORTS BBApply
= BEGIN OPEN BBApply, Rope, RTBasic, AMBridge, AMTypes, WorldVM;

ApplyErrorCode: TYPE = {none, badRange, badType};

IncompatibleNumberOfArgs: PUBLIC ERROR [expected, given: NAT] = CODE;
IncompatibleArgTypes: PUBLIC ERROR [index: NAT, expected, given: Type] = CODE;
IncompatibleArgRanges: PUBLIC ERROR [index: NAT, expected, given: Type] = CODE;
XferFailure: PUBLIC ERROR = CODE;

useAMEvents: BOOL ← TRUE;
ApplyProcToRecord: PUBLIC PROC
[proc: TV, args: TV ← NIL] RETURNS [rtns: TV] = TRUSTED {
-- takes a TV and applies it to its argument vector (as a TV)
-- args = NIL => no arguments
-- returns the result vector (NIL if no returns)
-- NO CHECKING OF args IS PERFORMED!!!
IF useAMEvents
THEN
rtns ← AMEvents.Apply[proc, args]
ELSE
{procDesc: PrincOps.ProcDesc ← LOOPHOLE[TVToProc[proc]];
procType: Type ← AMTypes.UnderType[TVType[proc]];
argsType: Type ← AMTypes.UnderType[Domain[procType]];
rtnsType: Type ← AMTypes.UnderType[Range[procType]];
numArgs, numArgWords, numRtns, numRtnWords: NAT ← 0;
p: POINTER ← @state.stk[0];
givenArgsType: Type ← nullType;
needFree: BOOL ← FALSE;
state: PrincOps.StateVector ←
[stk: ,
instbyte: 0,
stkptr: 0,
data: lst[dest: LOOPHOLE[procDesc], source: Self[]] ];
IF argsType # nullType THEN
{numArgs ← NComponents[argsType];
numArgWords ← CalculateRecordSize[argsType];
state.stkptr ← numArgWords};
IF rtnsType # nullType THEN
{numRtns ← NComponents[rtnsType];
numRtnWords ← CalculateRecordSize[rtnsType];
IF numRtnWords > PrincOps.MaxParamsInStack THEN needFree ← TRUE};
IF args # NIL THEN givenArgsType ← AMTypes.UnderType[TVType[args]];

state.stk ← ALL[0]; -- must clear out to handle fields properly

-- check type of arguments
IF givenArgsType # argsType
THEN ERROR IncompatibleArgTypes[0, argsType, givenArgsType];

IF numArgWords > PrincOps.MaxParamsInStack THEN
{state.stkptr ← 1;
p ← state.stk[0] ← Alloc[FrameSize[numArgWords]]};

-- fill up the arguments in the state vector
IF args # NIL THEN
[] ← ArgRecordMunger[p, argsType, args, fromTV];

TRANSFER WITH state; -- do the xfer
state ← STATE;

IF needFree
THEN p ← state.stk[0]
ELSE p ← @state.stk[0];

-- extract the results from the state vector
rtns ← ArgRecordMunger[p, rtnsType, NIL, toTV];

IF needFree THEN Free[state.stk[0]];
};
};

CoerceTV: PUBLIC PROC
[arg: TV, fullType: Type] RETURNS [rtn: TV] = TRUSTED {
givenType: Type ← AMTypes.UnderType[TVType[arg]];
givenClass: Class ← AMTypes.TypeClass[givenType];
targetType: Type ← AMTypes.UnderType[fullType];
targetClass: Class ← AMTypes.TypeClass[targetType];
isRemote: BOOL ← AMBridge.IsRemote[arg];
IF givenType = targetType THEN RETURN [arg];

{ENABLE
AMTypes.Error =>
SELECT reason FROM
noSymbols, internalTV => REJECT;
ENDCASE => GO TO badType;

-- if types are equivalent, then just LOOPHOLE
IF RTTypesBasic.EquivalentTypes[targetType, givenType] THEN
GO TO loophole;

-- if target is UNSPECIFIED, any 1-word match will do
IF targetClass = unspecified AND TVSize[arg] = 1 THEN
GO TO loophole;

-- if targetClass = givenClass, we have a few special cases
IF targetClass = givenClass THEN
SELECT targetClass FROM
rope, atom => GO TO loophole;
ENDCASE;

-- generate the default return
rtn ← AMTypes.New[fullType];

-- if target is UNSPECIFIED, any 1-word match will do
IF targetClass = unspecified AND TVSize[arg] = 1 THEN
{AMBridge.SetTVFromLC[rtn, AMBridge.TVToCardinal[arg]];
RETURN};

-- strip off useless layers of record
WHILE givenClass = record DO
n: NAT ← AMTypes.NComponents[givenType];
IF n # 1 THEN EXIT;
arg ← AMTypes.IndexToTV[arg, 1];
givenType ← AMTypes.UnderType[TVType[arg]];
givenClass ← AMTypes.TypeClass[givenType];
IF givenType = targetType THEN RETURN [arg];
ENDLOOP;

-- try to deal with coercion to REF ANY
IF targetType = RTTypesBasic.refAnyType THEN
{ref: REF ← NIL;
IF isRemote
THEN ERROR AMTypes.Error[notImplemented, "remote ref any"];
SELECT givenClass FROM
nil => RETURN [NIL];
ref, list, countedZone, uncountedZone, rope, atom =>
GO TO loophole;
globalFrame =>
ref ← z.NEW[PrincOps.GlobalFrameHandle ← AMBridge.GFHFromTV[arg]];
localFrame, descriptor, longDescriptor, union, sequence, opaque, any =>
GO TO badType;
ENDCASE =>
ref ← SomeRefFromTV[arg];
RETURN [AMBridge.TVForReferent[z.NEW[REF ← ref]]];
};

-- NIL is handled specially (note: rtn is already the right NIL)
IF givenClass = nil OR (givenClass = ref AND AMBridge.TVToLC[arg] = 0) THEN
SELECT targetClass FROM
list, procedure, signal, error, program, port, ref, pointer, longPointer, rope, atom,
unspecified, countedZone, uncountedZone, process, nil, descriptor, longDescriptor,
basePointer, relativePointer =>
RETURN;
ENDCASE => GO TO badType;

-- KLUDGE for conversion from REF opaque to REF concrete
-- VERY TEMPORARY (we hope)
IF targetClass = ref AND givenClass = ref AND NOT isRemote THEN {
ref: REF ← LOOPHOLE[AMBridge.TVToLC[arg]]; -- GACK!!
concrete: Type ← RTTypesBasic.GetReferentType[ref];
desiredConcrete: Type ← AMTypes.Range[targetType];
IF RTTypesBasic.EquivalentTypes[concrete, desiredConcrete] THEN
GO TO loophole;
};

SELECT targetClass FROM
longInteger, longCardinal, real, cardinal, character =>
{-- these are cases not handled properly by AMTypes.Coerce
int: LONG INTEGER ← 0;
lc: LONG CARDINAL ← 0;
givenType ← AMTypes.GroundStar[givenType];
givenClass ← AMTypes.TypeClass[givenType];
IF givenClass = targetClass THEN RETURN [arg];
SELECT givenClass FROM
cardinal, character => int ← AMBridge.TVToCardinal[arg];
integer => int ← AMBridge.TVToInteger[arg];
longInteger, longCardinal => int ← AMBridge.TVToLI[arg];
list, procedure, signal, error, ref, pointer, longPointer,
unspecified, countedZone, uncountedZone =>
{IF targetClass # longCardinal THEN GO TO badType;
int ← LOOPHOLE[AMBridge.TVToLC[arg]]};
ENDCASE => GO TO badType;
lc ← LOOPHOLE[int, LONG CARDINAL];
SELECT targetClass FROM
real => RETURN[TVForReadOnlyReferent[z.NEW[REAL ← int]]];
cardinal =>
{IF lc > LAST[CARDINAL] THEN GO TO badType;
AMBridge.SetTVFromLC[rtn, lc]};
character =>
{IF lc > LOOPHOLE[LAST[CHAR], CARDINAL] THEN GO TO badType;
AMBridge.SetTVFromLC[rtn, lc]};
longCardinal =>
AMBridge.SetTVFromLC[rtn, lc];
integer =>
{IF int < FIRST[INTEGER] OR int > LAST[INTEGER] THEN GO TO badType;
AMBridge.SetTVFromLI[rtn, int]};
ENDCASE => SetTVFromLI[rtn, int];
RETURN;
};
ENDCASE;
rtn ← AMTypes.Coerce[arg, fullType];
EXITS
loophole => RETURN [AMBridge.Loophole[arg, fullType]];
badType => ERROR AMTypes.Error[incompatibleTypes, NIL, givenType, fullType];
}};

-- hideous record size routines

cache: REF RecordSizeEntry ← NIL;

RecordSizeEntry: TYPE = RECORD
[next: REF RecordSizeEntry,
type: Type,
size: CARDINAL];

CalculateRecordSizeFailed: PUBLIC ERROR = CODE;

CalculateRecordSize: PUBLIC PROC
[type: Type] RETURNS [CARDINAL] = TRUSTED {
RETURN[DoCalculateRecordSize[type ! ABORTED => GO TO abort; ANY => CONTINUE]];
ERROR CalculateRecordSizeFailed;
EXITS abort => ERROR ABORTED;
};

DoCalculateRecordSize: ENTRY PROC
[type: Type] RETURNS [CARDINAL] = TRUSTED {
ENABLE UNWIND => NULL;
type ← AMTypes.UnderType[type];
IF type = nullType THEN RETURN [0];
FOR entry: REF RecordSizeEntry ← cache, entry.next UNTIL entry = NIL DO
IF type = entry.type THEN RETURN [entry.size]
ENDLOOP;
{-- we must make a new cache entry
-- however, we should first check for assignability of this type
words: CARDINAL ← Size[type];
new1: TV ← AMTypes.New[type];
new2: TV ← AMTypes.New[type];
AMTypes.Assign[new1, new2];
cache ← z.NEW[RecordSizeEntry ← [next: cache, type: type, size: words]];
RETURN [words];
};
};

SetVarsFromStateVector: PUBLIC PROC
[frame: TV, state: POINTER TO PrincOps.StateVector]
RETURNS [msg: ROPE] = TRUSTED {
-- NIL if succeded, reason if failed
ENABLE {
ABORTED => GO TO abort;
ANY => GO TO bye};
type, under: Type;
class: Class;
IF frame = NIL THEN RETURN ["NIL frame"];
class ← AMTypes.TypeClass[under ← AMTypes.UnderType[type ← TVType[frame]]];
IF class # localFrame THEN RETURN ["not a frame"];
IF AMBridge.IsRemote[frame] THEN RETURN [NIL];
msg ← "can't get proc from frame";
{fh: PrincOps.FrameHandle ← FHFromTV[frame];
fsize: CARDINAL ←
PrincOps.FrameVec[(LOOPHOLE[fh, POINTER TO CARDINAL] - 1)^];
src: POINTER ← @state.stk;
procType, recType: Type ← nullType;
procTV, recTV: TV ← NIL;
n, nwords: CARDINAL ← 0;
procTV ←
Procedure
[frame
! AMTypes.Error => CONTINUE];
IF procTV = NIL THEN
procTV ←
Signal
[frame
! AMTypes.Error => CONTINUE];
msg ← "proc type not available";
procType ← AMTypes.UnderType[TVType[procTV]];
recType ← AMTypes.Domain[procType];
IF recType # nullType THEN
{n ← NComponents[recType];
IF n > 0 THEN nwords ← AMTypes.Size[recType]};
msg ← "argument transfer failed";
IF nwords # state.stkptr THEN
{IF state.stkptr # 1 OR nwords < PrincOps.stackDepth THEN
RETURN ["bad stack depth"];
-- The StateVector has is a pointer to an arg record
src ← LOOPHOLE[src^]};
-- zero out the frame (to avoid seeing garbage)
FOR i: CARDINAL IN [0..fsize - 3) DO
fh.local[i] ← 0
ENDLOOP;
IF nwords = 0 THEN RETURN [NIL];
recTV ← AMBridge.TVForPointerReferent[src, recType];
FOR i: CARDINAL IN [1..n] DO
inFrame: TV ← AMTypes.Argument[frame, i];
inRec: TV ← AMTypes.IndexToTV[recTV, i];
AMTypes.Assign[inFrame, inRec]
ENDLOOP};
-- at this point, everything has succeded
RETURN [NIL];
EXITS
bye => {};
abort => ERROR ABORTED;
};

-- argument record extractors/depositors

ExtractRecordFromPointer: PUBLIC PROC
[world: World, p: Address, type: Type] RETURNS [record: TV] = TRUSTED {
src: TV ← NIL;
IF world = WorldVM.LocalWorld[]
THEN
src ← AMBridge.TVForPointerReferent[LOOPHOLE[p], type]
ELSE
{rp: AMBridge.RemotePointer ←
[world, WorldVM.CurrentIncarnation[world], p];
src ← AMBridge.TVForRemotePointerReferent[rp, type]};
IF type = nullType THEN RETURN [src];
record ← AMTypes.Copy[src];
};

DepositRecordToPointer: PUBLIC PROC
[world: World, p: Address, record: TV] = TRUSTED {
dst: TV ← NIL;
type: Type = AMTypes.UnderType[AMTypes.TVType[record]];
IF world = WorldVM.LocalWorld[]
THEN
dst ← AMBridge.TVForPointerReferent[LOOPHOLE[p], type]
ELSE
{rp: AMBridge.RemotePointer ←
[world, WorldVM.CurrentIncarnation[world], p];
dst ← AMBridge.TVForRemotePointerReferent[rp, type]};
AMTypes.Assign[dst, record];
};

ArgRecordMungerDirection: TYPE = {fromTV, toTV};

ArgRecordMunger: PROC
[p: LONG POINTER, type: Type, tv: TV ← NIL,
dir: ArgRecordMungerDirection ← toTV]
RETURNS [ntv: TV] = TRUSTED {
n: CARDINAL ← IF type = nullType THEN 0 ELSE NComponents[type];
sv: TV ← NIL;
pTV: TV ← NIL;
ntv ← tv;
pTV ← AMBridge.TVForPointerReferent[p, type];
IF n = 0 THEN RETURN [pTV];
IF dir = toTV
THEN ntv ← AMTypes.Copy[pTV]
ELSE AMTypes.Assign[pTV, ntv];
};

-- auxiliary routines for DoXfer

FSIndex: TYPE = [0..PrincOps.LastAVSlot];

Alloc: UNSAFE PROC [i: FSIndex] RETURNS [POINTER] = UNCHECKED MACHINE CODE
{Mopcodes.zALLOC};

FrameSize: PROC [nw: CARDINAL] RETURNS [fsi: FSIndex] = TRUSTED {
FOR fsi IN FSIndex
DO IF nw <= PrincOps.FrameVec[fsi] THEN RETURN ENDLOOP;
ERROR XferFailure};

Free: UNSAFE PROC [POINTER] = UNCHECKED MACHINE CODE {Mopcodes.zFREE};

Self: UNSAFE PROC RETURNS [PrincOps.ControlLink] = UNCHECKED MACHINE CODE {
Mopcodes.zLADRB, 0};

-- this is the zone for all of the local allocations

z: ZONE ← BBZones.GetPrefixedZone[];

END.

-- RRA, January 4, 1983 1:41 pm, added option (default TRUE) to use AMEvents.Apply
-- RRA, January 4, 1983 1:41 pm, added rope & atom coercions