AMVariablesImpl.mesa
Copyright © 1984, 1985 by Xerox Corporation. All rights reserved.
Russ Atkinson, February 20, 1985 8:18:05 pm PST
Richard Koo, July 2, 1984 8:35:25 pm PDT
DIRECTORY
AMBridge USING [GetWorld, nilRemotePointer, RemotePointer, SetTVFromLC, TVToLC, WordSequence, WordSequenceRecord],
AMTypes USING [Class, Coerce, Error, IndexToTV, NComponents, New, nullType, Tag, TV, TVEqual, TVSize, TVType, Type, UnderClass, VariableType],
PrincOpsUtils USING [LongCopy],
RCMap USING [nullIndex],
RTTypesBasicPrivate USING [AssignComposite, AssignCompositeNew, MapRefs, MapTiRcmx],
RTTypesPrivate USING [GetValueAddress, TypedVariableRec, ValueAddress],
RTTypesRemotePrivate USING [GetRemoteWords, RemoteStoreWords],
SafeStorage USING [EquivalentTypes, nullType, Type],
SafeStoragePrivate USING [ValidateRef];
AMVariablesImpl:
PROGRAM
IMPORTS AMBridge, AMTypes, PrincOpsUtils, SafeStoragePrivate, SafeStorage, RTTypesBasicPrivate, RTTypesPrivate, RTTypesRemotePrivate
EXPORTS AMTypes
= BEGIN OPEN AMTypes;
T Y P E S
TypedVariableRec: TYPE = RTTypesPrivate.TypedVariableRec;
emptyTV: TV ← NIL;
GetEmptyTV:
PUBLIC
SAFE
PROC
RETURNS [
TV] =
TRUSTED {
IF emptyTV =
NIL
THEN {
Sigh, have to construct this one on the fly
ws: AMBridge.WordSequence ← NEW[AMBridge.WordSequenceRecord[0]];
emptyTV ←
NEW[TypedVariableRec ← [
referentType: [SafeStorage.nullType, NIL],
head: [constant[]],
status: const,
field: constant[ws] ]];
};
RETURN[emptyTV];
};
Assign:
PUBLIC
SAFE
PROC [lhs:
TV, rhs:
TV] =
TRUSTED {
DoAssign[lhs, rhs];
};
AssignNew:
PUBLIC
SAFE
PROC [lhs:
TV, rhs:
TV] =
TRUSTED{
DoAssign[lhs, rhs, TRUE];
};
DoAssign:
PROC [lhs:
TV, rhs:
TV, new:
BOOL ←
FALSE] = {
raises typeFault, notImplemented, incompatibleTypes, notMutable
lhsType: Type = TVType[lhs];
rhsType: Type ← TVType[rhs];
rhsSize: INT ← TVSize[rhs];
lhsSize: INT ← TVSize[lhs];
lhsRemPtr: AMBridge.RemotePointer ← AMBridge.nilRemotePointer;
rhsPtr: LONG POINTER ← NIL;
unCountedAssignment: BOOL;
isRC: BOOL ← IsRC[lhsType];
lhsa: RTTypesPrivate.ValueAddress ← RTTypesPrivate.GetValueAddress[tv: lhs, mutableOnly: TRUE];
ws: AMBridge.WordSequence ← NIL;
SELECT UnderClass[lhsType]
FROM
any, globalFrame, localFrame => Error[reason: typeFault, type: lhsType];
ENDCASE;
SELECT UnderClass[rhsType]
FROM
any, globalFrame, localFrame => Error[reason: typeFault, type: rhsType];
ENDCASE;
{
be real careful not to use the size field of lhsa if new
rhsa: RTTypesPrivate.ValueAddress ← RTTypesPrivate.GetValueAddress[rhs];
lhsa ← RTTypesPrivate.GetValueAddress[tv: lhs, mutableOnly: TRUE];
IF
NOT AsGoodAs[rhsType: rhsType, lhsType: lhsType]
THEN {
Try to coerce the right hand to the lhs type
ENABLE AMTypes.Error => IF reason = typeFault THEN GO TO incompatible;
rhs ← AMTypes.Coerce[rhs, lhsType];
rhsType ← AMTypes.TVType[rhs];
rhsSize ← AMTypes.TVSize[rhs];
};
IF AMTypes.TVEqual[lhs, rhs]
THEN
RETURN;
If the value we are assigning is already the same as the value that is present, then we do not need to move the bits at all.
WITH lhs
SELECT
FROM
tr:
REF TypedVariableRec =>
WITH tr.head
SELECT
FROM
constant, remoteConstant => ERROR Error[reason: notMutable];
reference, gfh => unCountedAssignment ← FALSE;
pointer, fh, remoteReference, copiedRemoteObject,
remotePointer, remoteGFH, remoteFH => unCountedAssignment ← TRUE;
ENDCASE => ERROR;
ENDCASE => ERROR;
SELECT
TRUE
FROM
isRC
AND ((lhsa.tag = remotePointer)
OR (lhsa.tag = pointer AND rhsa.tag = remotePointer)
OR (lhsa.tag = pointer AND rhsa.tag = copiedRemoteObject)
OR (lhsa.tag = copiedRemoteObject AND rhsa.tag = pointer)
) => {
We may be trying to perform remote reference counting, so we really can't do this assignment, UNLESS the source = NIL.
IF rhsSize <= 2
AND AMBridge.TVToLC[rhs] = 0
THEN {
Source = NIL, so force uncounted assignment. This may leave the current destination RC too high, but at least we will be able to complete the assignment.
rhsPtr ← @ws; -- the address of a NIL double-word
GO TO copy;
};
We cannot do this assignment and keep things safe, so we raise an error (sigh).
ERROR Error[reason: notImplemented, msg: "remote reference-counted assignment"];
};
rhsType = nullType => {
rhsPtr ← @ws; -- the address of a NIL double-word
SELECT UnderClass[lhsType]
FROM
list, ref, atom, rope, countedZone => {
this bunch is RC, so we can't use the copy outlet
IF unCountedAssignment OR new THEN GO TO copy;
LOOPHOLE[
NARROW[lhsa, pointer RTTypesPrivate.ValueAddress].ptr,
REF REF ANY]^ ← NIL;
RETURN;
};
pointer, longPointer, procedure, signal, error => GO TO copy;
basePointer, relativePointer, uncountedZone => GO TO copy;
ENDCASE => GO TO incompatible;
};
ENDCASE;
IF
NOT new
AND rhsSize > lhsSize
THEN
may be an uninitialized union or seq
GO TO incompatible;
IF rhsSize = 0 THEN RETURN;
IF NOT isRC AND rhsSize <= 2 THEN GO TO smallAssign;
WITH t: rhsa
SELECT
FROM
constant => {
rhsPtr ← @t.value[0];
IF unCountedAssignment THEN GO TO copy ELSE GO TO rcAssign;
};
pointer => {
WITH fd: t.fd
SELECT
FROM
large => {
rhsPtr ← t.ptr;
WITH rhs
SELECT
FROM
tr:
REF TypedVariableRec =>
WITH tr.head
SELECT
FROM
fh => {
validate rhs
procLeaf: PROC [r: REF ANY] = {SafeStoragePrivate.ValidateRef[r]};
RTTypesBasicPrivate.MapRefs[
ptr: t.ptr,
rcmx: RTTypesBasicPrivate.MapTiRcmx[rhsType],
procLeaf: procLeaf];
};
ENDCASE;
ENDCASE;
SELECT
TRUE
FROM
unCountedAssignment =>
NOTE remote RC not allowed (except for NIL)
WITH fd: t.fd
SELECT
FROM
large => {rhsPtr ← t.ptr; GO TO copy};
small => GO TO smallAssign;
ENDCASE => ERROR;
ENDCASE => GO TO rcAssign
};
small => GO TO smallAssign;
ENDCASE => ERROR};
remotePointer => {
rhsa.tag = remotePointer
WITH fd: t.fd
SELECT
FROM
large => {
ws ← RTTypesRemotePrivate.GetRemoteWords[t.ptr, rhsSize];
rhsPtr ← @ws[0];
GO TO copy;
};
small => GO TO smallAssign;
ENDCASE => ERROR};
copiedRemoteObject => {
rhsa.tag = copiedRemoteObject
WITH fd: t.fd
SELECT
FROM
large => {rhsPtr ← t.ptr; GO TO copy};
small => GO TO smallAssign;
ENDCASE => ERROR;
};
ENDCASE => ERROR;
EXITS
copy => {
must not be RC (except for NIL)
lhsPtr: LONG POINTER ← NIL;
WITH lh: lhsa
SELECT
FROM
remotePointer =>
RTTypesRemotePrivate.RemoteStoreWords[from: rhsPtr, to: lh.ptr, nWords: rhsSize];
pointer => PrincOpsUtils.LongCopy[from: rhsPtr, to: lh.ptr, nwords: rhsSize];
copiedRemoteObject =>
PrincOpsUtils.LongCopy[from: rhsPtr, to: lh.ptr, nwords: rhsSize];
ENDCASE => ERROR;
};
rcAssign => {
must be RC
lhsPtr: LONG POINTER ← NARROW[lhsa, pointer RTTypesPrivate.ValueAddress].ptr;
IF new
THEN RTTypesBasicPrivate.AssignCompositeNew[rhs: rhsPtr, lhs: lhsPtr, type: rhsType, nwords: rhsSize]
ELSE RTTypesBasicPrivate.AssignComposite[rhs: rhsPtr, lhs: lhsPtr, type: rhsType, nwords: rhsSize];
};
smallAssign =>
must not be RC
AMBridge.SetTVFromLC[lhs, AMBridge.TVToLC[rhs]];
incompatible =>
we just can't assign these guys
ERROR Error[reason: incompatibleTypes, type: lhsType, otherType: rhsType];
};
TVTag:
PROC [tv:
TV]
RETURNS [
TV] = {
private version, assumes tv # NIL (copied in RTTypesBridgeImpl)
RETURN[NARROW[tv, REF TypedVariableRec].referentType.tag];
};
Copy:
PUBLIC
SAFE
PROC [tv:
TV]
RETURNS [newTV:
TV ←
NIL] =
TRUSTED {
IF tv #
NIL
THEN {
tag: TV ← TVTag[tv];
type: Type ← TVType[tv];
IF tag =
NIL
THEN {
variantClass: Class = VariableType[type].c;
SELECT variantClass
FROM
union, sequence => tag ← Tag[IndexToTV[tv, NComponents[type]]];
ENDCASE;
};
newTV ← New[world: AMBridge.GetWorld[tv], type: type, tag: tag];
DoAssign[lhs: newTV, rhs: tv, new: TRUE];
};
};
IsRC:
PROC [type: Type]
RETURNS [ans:
BOOL] = {
private version, assumes tv # NIL (copied in RTTypesBridgeImpl)
RETURN[RTTypesBasicPrivate.MapTiRcmx[type] # RCMap.nullIndex];
};
AsGoodAs:
PROC [rhsType,lhsType: Type]
RETURNS [
BOOL] = {
private version, assumes tv # NIL (copied in RTTypesBridgeImpl)
NOTE freely conforms = Equivalent for now
RETURN[SafeStorage.EquivalentTypes[rhsType,lhsType]];
};
END.