[_CDCSL_93-16_]<1>Cedar>release>MimosaOnly>Pass3M.mesa

Pass3M.mesa

Satterthwaite, June 18, 1986 12:30:20 pm PDT

Russ Atkinson (RRA) July 18, 1988 3:32:49 pm PDT

DIRECTORY

Alloc USING [Notifier, Top],

ConvertUnsafe USING [SubString],

MimData USING [bitsToAlignment, bodyIndex, idLOCK, idUNWIND, ownSymbols, seAnon, table, textIndex, typeCONDITION, typeListANY, typeLOCK, worstAlignment],

MimosaCopier USING [CompleteContext],

MimosaLog USING [Error, ErrorNode, ErrorSei, ErrorTree, ErrorTreeOp],

MimP3 USING [And, Apply, AssignDefaults, Attr, BindTree, BoundNP, BumpArgRefs, CheckLength, CheckLocals, CheckScope, ClearRefStack, EnterComposite, EnterType, Exp, FieldVoid, FirstId, fullAttr, InitialExp, KeyedList, lockNode, MakeLongType, MakeRefType, MatchFields, MergeNP, NPUse, pathNP, phraseNP, PopCtx, PushCtx, RAttrPop, Rhs, RPop, RPush, RType, Safety, SafetyAttr, SealRefStack, SearchCtxList, SequenceNP, SetNP, SetSafety, SetType, Stmt, TextForm, TypeAppl, UnsealRefStack, UpdateTreeAttr, UType, VoidComponent, VoidExp],

MimP3S USING [BodyData, continued, currentBody, markCatch, safety],

Pass3Attributes USING [AssignableType, Bundling, CanonicalType, DefaultInit, LongPath, LongType, NewableType, OperandInternal, OperandLhs, OperandType, TargetType, TypeForTree, Unbundle, Voidable],

SourceMap USING [Loc],

Symbols USING [Base, BitOrder, BodyRecord, bodyType, BTFirst, BTIndex, CBTIndex, CBTNull, CSEIndex, CSENull, CTXIndex, CTXNull, ctxType, HTIndex, HTNull, ISEIndex, ISENull, lG, lZ, mdType, nullType, RecordSEIndex, RecordSENull, RefSEIndex, RootBti, SERecord, seType, Type, typeANY],

SymbolOps USING [ArgCtx, ArgRecord, CopyXferType, CtxLevel, DecodeBti, EnterString, EqTypes, FindString, FirstCtxSe, FromType, MakeNonCtxSe, NextSe, NormalType, own, ReferentType, SetCtxLevel, TransferTypes, TypeForm, TypeRoot, UnderType, XferMode],

Target: TYPE MachineParms USING [bitOrder, bitsPerAU, bitsPerLongWord, bitsPerProcess, bitsPerProgram, bitsPerRef, bitsPerWord],

Tree USING [Base, Index, Link, Map, NodeName, Null, nullIndex, Scan, treeType],

TreeOps USING [FreeNode, FreeTree, FromLoc, GetNode, GetTag, IdentityMap, MakeList, MakeNode, NthSon, PopTree, PushTree, PushSe, PushNode, PutAttr, OpName, ReverseUpdateList, ScanList, SetAttr, SetInfo, ToLoc, UpdateList],

Types USING [Assignable, Equivalent];

Pass3M: PROGRAM

IMPORTS Alloc, MimData, MimosaCopier, MimosaLog, MimP3, MimP3S, Pass3Attributes, SymbolOps, TreeOps, Types

EXPORTS MimP3 = {

OPEN MimP3, Pass3Attributes, Symbols, TreeOps;

targetBitOrder: Symbols.BitOrder = SELECT Target.bitOrder FROM

msBit => msBit, lsBit => lsBit, ENDCASE => ERROR;

checkLong: BOOL = Target.bitsPerLongWord # Target.bitsPerWord;

InsertCatchLabel: PUBLIC SIGNAL [catchSeen, exit: BOOL] = CODE;

tb: Tree.Base; -- tree base address (local copy)

seb: Symbols.Base; -- se table base address (local copy)

ctxb: Symbols.Base; -- context table base (local copy)

mdb: Symbols.Base; -- module table base (local copy)

bb: Symbols.Base; -- body table base (local copy)

MiscNotify: PUBLIC Alloc.Notifier = {

called by allocator whenever table area is repacked

tb ¬ base[Tree.treeType];

seb ¬ base[seType];

ctxb ¬ base[ctxType];

mdb ¬ base[mdType];

bb ¬ base[bodyType];

};

current: POINTER TO MimP3S.BodyData = @MimP3S.currentBody;

Statements

MiscStmt: PUBLIC PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {

name: Tree.NodeName = tb[node].name;

val ¬ [subtree[index: node]]; -- the default

SELECT name FROM

signal, error, start, join, wait => {

new: Tree.Link;

IF name = wait

THEN {

son1: Tree.Link ¬ SampleAndFree[node, 1];

subNode: Tree.Index;

saveNP: NPUse;

IF NOT current.lockHeld THEN MimosaLog.Error[misplacedMonitorRef];

subNode ¬ Apply[GetNode[ForceApplication[son1]], typeANY, TRUE];

SELECT tb[subNode].name FROM

wait, apply => NULL;

ENDCASE => MimosaLog.ErrorTreeOp[missingOp, tb[subNode].son[1], wait];

IF OperandLhs[tb[subNode].son[1]] = none THEN

MimosaLog.ErrorTree[nonLHS, tb[subNode].son[1]];

[] ¬ FreeTree[tb[subNode].son[2]];

saveNP ¬ phraseNP;

tb[subNode].son[2] ¬ tb[subNode].son[1];

tb[subNode].son[1] ¬ CopyLock[];

phraseNP ¬ MergeNP[saveNP][phraseNP];

new ¬ [subtree[subNode]];

}

ELSE new ¬ MiscXfer[node, typeANY];

PushTree[new];

SELECT RType[] FROM

CSENull, typeANY => NULL;

ENDCASE => MimosaLog.Error[nonVoidStmt];

SetInfo[FromLoc[MimData.textIndex]];

val ¬ PopTree[];

RPop[];

pathNP ¬ SequenceNP[pathNP][phraseNP];

IF name = error THEN current.reachable ¬ FALSE;

};

xerror => {

subNode: Tree.Index;

IF current.catchDepth # 0 THEN MimosaLog.Error[misplacedReturn];

tb[node].name ¬ error;

val ¬ MiscStmt[node]; subNode ¬ GetNode[val];

IF tb[subNode].attr1 THEN MimosaLog.ErrorTree[typeClash, val];

SELECT tb[subNode].name FROM

error, errorx => tb[subNode].name ¬ xerror;

ENDCASE;

tb[subNode].attr1 ¬ current.entry;

tb[subNode].attr3 ¬ FALSE;

IF current.entry THEN tb[subNode].attr2 ¬ CheckLocals[tb[subNode].son[2]];

IF tb[subNode].nSons > 2 THEN MimosaLog.Error[misplacedCatch];

current.reachable ¬ FALSE;

};

resume => {

rSei: RecordSEIndex = current.resumeRecord;

son: Tree.Link ¬ tb[node].son[1];

IF NOT current.resumeFlag THEN MimosaLog.Error[misplacedResume];

IF rSei # RecordSENull AND son = Tree.Null

THEN {

n: CARDINAL ¬ 0;

BumpArgRefs[rSei, FALSE];

FOR sei: ISEIndex ¬ SymbolOps.FirstCtxSe[SymbolOps.own, seb[rSei].fieldCtx], SymbolOps.NextSe[SymbolOps.own, sei]
UNTIL sei = ISENull DO

n ¬ n+1;

IF n=1 AND seb[sei].hash = HTNull THEN MimosaLog.Error[illDefinedReturn];

PushSe[sei];

ENDLOOP;

tb[node].son[1] ¬ son ¬ MakeList[n];

}

ELSE {

tb[node].son[1] ¬ son ¬ IF tb[node].attr1 AND rSei # RecordSENull

THEN Rhs[son, rSei]

ELSE MatchFields[rSei, son];

RPop[];

pathNP ¬ SequenceNP[pathNP][phraseNP];

};

current.reachable ¬ FALSE;

};

reject => {

IF current.catchDepth = 0 THEN MimosaLog.Error[misplacedResume];

current.reachable ¬ FALSE;

};

continue, retry => {

SIGNAL InsertCatchLabel[catchSeen: FALSE, exit: name=continue];

current.reachable ¬ FALSE;

};

notify, broadcast => {

type: Type;

son1: Tree.Link ¬ tb[node].son[1];

IF ~current.lockHeld THEN MimosaLog.Error[misplacedMonitorRef];

son1 ¬ tb[node].son[1] ¬ Exp[son1, typeANY];

IF OperandLhs[son1] = none THEN MimosaLog.ErrorTree[nonLHS, son1];

type ¬ RType[];

RPop[];

pathNP ¬ SequenceNP[pathNP][phraseNP];

IF ~SymbolOps.EqTypes[SymbolOps.own, type, MimData.typeCONDITION] THEN

MimosaLog.ErrorTreeOp[missingOp, son1, name]

};

free => {

type: Type;

subType, nType: CSEIndex;

long, counted: BOOL;

son1: Tree.Link ¬ tb[node].son[1];

son2: Tree.Link ¬ tb[node].son[2];

[v: son1, long: long, counted: counted] ¬ EvalZone[son1];

tb[node].son[1] ¬ son1;

RPop[];

IF counted AND OpName[son2] = addr THEN PutAttr[son2, 1, TRUE];

son2 ¬ tb[node].son[2] ¬ Exp[son2, typeANY];

type ¬ RType[];

RPop[];

subType ¬ SymbolOps.NormalType[SymbolOps.own, type];

WITH s: seb[subType] SELECT FROM

ref => {

IF s.readOnly THEN MimosaLog.ErrorTree[typeClash, son2];

IF checkLong AND long # LongType[s.refType] THEN GO TO fail;

nType ¬ SymbolOps.NormalType[SymbolOps.own, s.refType];

WITH t: seb[nType] SELECT FROM

ref => IF t.counted # counted THEN GO TO fail;

ENDCASE => GO TO fail;

IF MimP3S.safety = checked AND ~counted THEN

MimosaLog.ErrorNode[unsafeOperation, node];

EXITS

fail => MimosaLog.ErrorTree[typeClash, son2];

};

ENDCASE => MimosaLog.ErrorTree[typeClash, son2];

IF tb[node].nSons > 3 THEN {

saveNP: NPUse = phraseNP;

[] ¬ CatchPhrase[tb[node].son[4]];

phraseNP ¬ MergeNP[saveNP][phraseNP];

};

tb[node].attr2 ¬ long;

tb[node].attr3 ¬ counted;

SELECT TRUE FROM

NOT counted =>

tb[node].attr1 ¬ FALSE;

(OpName[son2] # addr) => {

MimosaLog.ErrorTree[nonVar, son2];

tb[node].attr1 ¬ FALSE;

};

ENDCASE =>

tb[node].attr1 ¬ OperandLhs[NthSon[son2, 1]] = counted;

};

enable => {

saveEnabled: BOOL = current.unwindEnabled;

IF CatchPhrase[tb[node].son[1]].unwindCaught THEN current.unwindEnabled ¬ TRUE;

IF phraseNP # none THEN pathNP ¬ unsafe;

tb[node].son[2] ¬ UpdateList[tb[node].son[2], Stmt];

tb[node].attr3 ¬ FALSE;

current.unwindEnabled ¬ saveEnabled;

};

ENDCASE => MimosaLog.Error[unimplemented];

};

Dynamic storage allocation

New: PUBLIC PROC [node: Tree.Index, target: Type] = {

pType: RefSEIndex;

subType: Type;

attr: Attr;

saveNP: NPUse;

long, counted: BOOL;

zoneTree: Tree.Link ¬ tb[node].son[1];

typeTree: Tree.Link ¬ tb[node].son[2];

initTree: Tree.Link ¬ tb[node].son[3];

[v: zoneTree, long: long, counted: counted] ¬ EvalZone[zoneTree];

tb[node].son[1] ¬ zoneTree;

attr ¬ RAttrPop[];

saveNP ¬ phraseNP;

current.noXfers ¬ attr.noXfer ¬ attr.const ¬ FALSE;

tb[node].son[2] ¬ typeTree ¬ TypeAppl[typeTree];

attr ¬ And[attr, RAttrPop[]];

saveNP ¬ MergeNP[saveNP][phraseNP];

subType ¬ TypeForTree[typeTree];

IF NOT NewableType[subType] THEN MimosaLog.ErrorTree[typeLength, typeTree];

IF counted THEN EnterType[SymbolOps.TypeRoot[SymbolOps.own, subType], FALSE];

IF initTree = Tree.Null

THEN

No explicit initialization

initTree ¬ DefaultInit[subType]

ELSE {

StringInit: PROC [t: Tree.Link] RETURNS [BOOL] = INLINE {

RETURN [SELECT OpName[t] FROM

stringinit => TRUE,

lengthen => (OpName[NthSon[t, 1]] = stringinit),

ENDCASE => FALSE]

};

extFlag: BOOL;

[initTree, extFlag] ¬ InitialExp[initTree, subType];

SELECT TRUE FROM

extFlag => MimosaLog.ErrorTree[misusedInline, initTree];

StringInit[initTree] => MimosaLog.ErrorTree[defaultForm, initTree];

ENDCASE => initTree ¬ CheckInit[initTree, subType, counted];

};

tb[node].son[3] ¬ initTree;

attr ¬ And[attr, RAttrPop[]];

phraseNP ¬ SequenceNP[saveNP][phraseNP];

pType ¬ MakeRefType[

cType: subType,

bits: Target.bitsPerRef,

readOnly: tb[node].attr1, counted: counted,

hint: SymbolOps.NormalType[SymbolOps.own, target]];

IF initTree = Tree.Null

THEN {

No explicit or default initialization

IF NOT Voidable[subType] THEN MimosaLog.ErrorNode[missingInit, node];

}

ELSE {

Explicit initialization

IF counted THEN

EnterComposite[SymbolOps.UnderType[SymbolOps.own, subType], initTree, TRUE];

};

IF tb[node].nSons > 3 THEN {

saveNP: NPUse = phraseNP;

[] ¬ CatchPhrase[tb[node].son[4]];

phraseNP ¬ MergeNP[saveNP][phraseNP];

};

tb[node].attr2 ¬ long;

tb[node].attr3 ¬ counted;

RPush[IF checkLong AND long THEN MakeLongType[pType, target] ELSE pType, attr];

};

EvalZone: PROC [t: Tree.Link] RETURNS [v: Tree.Link, long, counted: BOOL] = {

long ¬ counted ¬ TRUE;

IF t = Tree.Null

THEN {v ¬ Tree.Null; RPush[typeANY, fullAttr]}

ELSE {

nDerefs: CARDINAL ¬ 0;

type: Type;

v ¬ Exp[t, typeANY];

type ¬ RType[];

nType: CSEIndex ¬ SymbolOps.NormalType[SymbolOps.own, type];

WITH s: seb[nType] SELECT FROM

zone => {

long ¬ ~s.mds;

counted ¬ s.counted;

GO TO success;

};

ref => {

IF (nDerefs ¬ nDerefs + 1) > 16 THEN GO TO failure;

PushTree[v];

PushNode[uparrow, 1];

SetAttr[2, LongType[type]];

type ¬ s.refType;

SetType[type];

v ¬ PopTree[];

};

record =>

IF Bundling[nType] # 0

THEN type ¬ Unbundle[LOOPHOLE[nType, RecordSEIndex]]

ELSE GO TO failure;

ENDCASE => GO TO failure;

ENDLOOP;

EXITS

success => {};

failure => MimosaLog.ErrorTree[typeClash, v];

};

List allocation

Cons: PUBLIC PROC [node: Tree.Index, target: Type] RETURNS [Tree.Link] = {

type: Type = SymbolOps.ReferentType[SymbolOps.own, ListType[target, [subtree[node]]]];

PushTree[tb[node].son[1]];

tb[node].son[1] ¬ Tree.Null;

PushNode[implicitTC, 0];

SetType[SymbolOps.UnderType[SymbolOps.own, type]];

CheckLength[tb[node].son[2], 2];

PushTree[tb[node].son[2]];

tb[node].son[2] ¬ Tree.Null;

PushTree[Tree.Null];

PushNode[apply, -2];

SetAttr[1, FALSE];

IF tb[node].nSons > 2

THEN {

PushTree[tb[node].son[3]];

tb[node].son[3] ¬ Tree.Null;

PushNode[new, 4];

}

ELSE PushNode[new, 3];

FreeNode[node];

RETURN [Exp[PopTree[], target]];

};

ListCons: PUBLIC PROC [node: Tree.Index, target: Type] = {

lType: CSEIndex = ListType[target, [subtree[node]]];

nType: Type = SymbolOps.ReferentType[SymbolOps.own, lType];

componentType: Type = ItemType[nType];

cType: Type = TargetType[componentType];

attr: Attr;

exitNP: NPUse;

long, counted: BOOL;

started: BOOL ¬ FALSE;

MapValue: Tree.Map = {

type: Type;

subAttr: Attr;

IF ~started AND KeyedList[t] THEN MimosaLog.Error[keys];

v ¬ SELECT TRUE FROM

(t = Tree.Null) => DefaultInit[componentType],

(OpName[t] = void) => FieldVoid[t],

ENDCASE => Rhs[t, cType];

type ¬ RType[];

subAttr ¬ RAttrPop[];

SELECT TRUE FROM

v = Tree.Null =>

VoidComponent[componentType];

counted =>

EnterComposite[SymbolOps.UnderType[SymbolOps.own, componentType], v, TRUE];

ENDCASE;

v ¬ CheckInit[v, type, TRUE];

exitNP ¬ MergeNP[exitNP][phraseNP];

attr ¬ And[attr, subAttr];

started ¬ TRUE;

};

[v: tb[node].son[1], long: long, counted: counted] ¬ EvalZone[tb[node].son[1]];

attr ¬ RAttrPop[];

exitNP ¬ phraseNP;

current.noXfers ¬ attr.noXfer ¬ attr.const ¬ FALSE;

IF counted THEN EnterType[SymbolOps.TypeRoot[SymbolOps.own, nType], FALSE];

tb[node].son[2] ¬ ReverseUpdateList[tb[node].son[2], MapValue];

tb[node].attr2 ¬ long;

tb[node].attr3 ¬ counted;

RPush[lType, attr];

phraseNP ¬ exitNP;

};

ListType: PROC [target: Type, t: Tree.Link] RETURNS [lType: CSEIndex] = {

subType: CSEIndex = SymbolOps.NormalType[SymbolOps.own, target];

WITH r: seb[subType] SELECT FROM

ref => {

rType: CSEIndex = SymbolOps.UnderType[SymbolOps.own, r.refType];

IF ~r.list AND (seb[rType].typeTag = any OR rType = typeANY)

THEN

lType ¬ MimData.typeListANY

ELSE {

IF ~r.list

THEN {MimosaLog.ErrorTree[typeClash, t]; lType ¬ typeANY}

ELSE lType ¬ SymbolOps.UnderType[SymbolOps.own, target];

};

ENDCASE =>

IF subType = typeANY

THEN lType ¬ MimData.typeListANY

ELSE {MimosaLog.ErrorTree[typeClash, t]; lType ¬ typeANY};

};

ItemType: PUBLIC PROC [nType: Type] RETURNS [Type] = {

sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, nType];

WITH r: seb[sei] SELECT FROM

record => RETURN [seb[SymbolOps.FirstCtxSe[SymbolOps.own, r.fieldCtx]].idType];

ENDCASE => RETURN [typeANY];

};

Control transfers

MiscXfer: PUBLIC PROC [node: Tree.Index, target: Type] RETURNS [val: Tree.Link] = {

val ¬ [subtree[node]];

SELECT tb[node].name FROM

signal, error, signalx, errorx => val ¬ Signal[node];

create => val ¬ Create[node, target];

start, startx => {

subNode: Tree.Index ¬ Apply[
GetNode[ForceApplication[tb[node].son[1]]], typeANY, TRUE];

SELECT tb[subNode].name FROM

start, startx, apply => NULL;

ENDCASE => MimosaLog.ErrorTreeOp[missingOp, tb[subNode].son[1], start];

tb[node].son[1] ¬ Tree.Null;

FreeNode[node];

val ¬ [subtree[subNode]];

};

fork => val ¬ Fork[node, target];

join, joinx => {

son1: Tree.Link ¬ SampleAndFree[node, 1];

subNode: Tree.Index ¬ Apply[GetNode[ForceApplication[son1]], typeANY, TRUE];

SELECT tb[subNode].name FROM

join, joinx, apply => {};

ENDCASE => MimosaLog.ErrorTreeOp[missingOp, tb[subNode].son[1], join];

val ¬ [subtree[subNode]];

};

ENDCASE => MimosaLog.Error[unimplemented];

};

MakeFrameRecord: PUBLIC PROC [t: Tree.Link] RETURNS [rSei: CSEIndex ¬ typeANY] = {

bti: CBTIndex = XferBody[t];

IF bti # CBTNull

THEN {

argType: Type = SymbolOps.TransferTypes[SymbolOps.own, bb[bti].ioType].typeIn;

rSei ¬ bb[bti].type;

IF rSei = RecordSENull OR argType # nullType THEN {

Allocate the frame record

rSei ¬ LOOPHOLE[SymbolOps.MakeNonCtxSe[SERecord.cons.record.linked.SIZE]];

seb[rSei] ¬ SERecord[mark3: TRUE, mark4: FALSE, body: cons[

align: MimData.worstAlignment,

typeInfo: record[

painted: TRUE,

machineDep: FALSE, argument: FALSE, packed: FALSE, spare: FALSE, list: FALSE,

bitOrder: targetBitOrder,

grain: Target.bitsPerAU,

hints: [

unifield: FALSE, variant: FALSE,

assignable: FALSE, comparable: FALSE, privateFields: TRUE,

refField: TRUE, default: FALSE, voidable: FALSE],

fieldCtx: bb[bti].localCtx,

length: IF bb[bti].type # RecordSENull THEN seb[bb[bti].type].length ELSE 0,

monitored: bb[bti].monitored,

linkPart: linked[argType]]]];

};

WITH r: seb[rSei] SELECT FROM

record => {

ctx: CTXIndex ¬ r.fieldCtx;

WITH ct: ctxb[ctx] SELECT FROM

included => MimosaCopier.CompleteContext[LOOPHOLE[ctx], rc];

ENDCASE;

};

ENDCASE => ERROR;

}

ELSE MimosaLog.Error[nonTypeCons];

};

XferBody: PROC [t: Tree.Link] RETURNS [bti: CBTIndex ¬ CBTNull] = {

WITH t SELECT GetTag[t] FROM

symbol => {

sei: ISEIndex = index;

type: Type = seb[sei].idType;

SELECT SymbolOps.TypeForm[SymbolOps.own, type] FROM

$transfer =>

IF seb[sei].immutable THEN

SELECT SymbolOps.XferMode[SymbolOps.own, type] FROM

$program =>

SELECT TRUE FROM

~ seb[sei].mark4 => bti ¬ RootBti;

seb[sei].constant => bti ¬ SymbolOps.DecodeBti[seb[sei].idInfo];

ENDCASE;

$proc =>

IF sei = bb[MimData.bodyIndex].id THEN bti ¬ MimData.bodyIndex;

ENDCASE;

};

ENDCASE;

};

XferForFrame: PUBLIC PROC [ctx: CTXIndex] RETURNS [CSEIndex] = {

bti: BTIndex ¬ BTFirst;

btLimit: BTIndex = (MimData.table).Top[bodyType];

UNTIL bti = btLimit DO

WITH entry: bb[bti] SELECT FROM

Callable => {

IF entry.localCtx = ctx THEN RETURN [entry.ioType];

bti ¬ bti + BodyRecord.Callable.SIZE;

};

ENDCASE => bti ¬ bti + BodyRecord.Other.SIZE;

ENDLOOP;

RETURN [CSENull];

};

Create: PROC [node: Tree.Index, target: Type] RETURNS [val: Tree.Link] = {

subNode: Tree.Index ¬ GetNode[

val ¬ ForceApplication[SampleAndFree[node, 1]]

];

type, mType, rType: CSEIndex;

attr: Attr;

CreateError: PROC = {

MimosaLog.ErrorTreeOp[missingOp, tb[subNode].son[1], create];

type ¬ typeANY;

};

tb[subNode].name ¬ create;

tb[subNode].attr1 ¬ TRUE;

tb[subNode].son[1] ¬ Exp[tb[subNode].son[1], typeANY];

mType ¬ UType[];

attr ¬ RAttrPop[];

phraseNP ¬ SetNP[phraseNP];

WITH m: seb[mType] SELECT FROM

transfer =>

IF m.mode = program

THEN

SELECT XferBody[tb[subNode].son[1]] FROM

CBTNull => type ¬ mType;

RootBti => {

type ¬ (IF SymbolOps.TypeForm[SymbolOps.own, target] = $ref

THEN MakeRefType[

cType: MakeFrameRecord[tb[subNode].son[1]],

hint: target,

bits: Target.bitsPerProgram]

ELSE mType);

tb[subNode].attr1 ¬ FALSE};

ENDCASE => CreateError[]

ELSE CreateError[];

ref => {

type ¬ mType;

rType ¬ SymbolOps.UnderType[SymbolOps.own, m.refType];

WITH r: seb[rType] SELECT FROM

record =>

SELECT TRUE FROM

(SymbolOps.CtxLevel[SymbolOps.own, r.fieldCtx] # lG) => CreateError[];

(SymbolOps.TypeForm[SymbolOps.own, target] = $transfer) => {

type ¬ XferForFrame[r.fieldCtx];

IF type = CSENull THEN {

MimosaLog.Error[unimplemented];

type ¬ typeANY;

};

ENDCASE;

ENDCASE => IF m.refType # typeANY THEN CreateError[];

};

ENDCASE => IF mType = typeANY THEN type ¬ typeANY ELSE CreateError[];

IF tb[subNode].son[2] # Tree.Null THEN {

MimosaLog.ErrorTree[noApplication, tb[subNode].son[1]];

tb[subNode].son[2] ¬ UpdateList[tb[subNode].son[2], VoidExp];

};

IF tb[subNode].nSons > 2 THEN [] ¬ CatchPhrase[tb[subNode].son[3]];

current.noXfers ¬ attr.noXfer ¬ attr.const ¬ FALSE;

RPush[type, attr];

};

Fork: PROC [node: Tree.Index, target: Type] RETURNS [Tree.Link] = {

subNode: Tree.Index;

type: CSEIndex;

attr: Attr;

t: Tree.Link ¬ ForceApplication[SampleAndFree[node, 1]];

subNode ¬ Apply[GetNode[t], typeANY, TRUE];

attr ¬ RAttrPop[];

SELECT tb[subNode].name FROM

call, callx => {

s: Tree.Link ¬ tb[subNode].son[1];

subType: CSEIndex;

IF OpName[s] = thread THEN {

s ¬ NthSon[s, 1];

MimosaLog.ErrorTree[misusedInline, s];

};

IF current.lockHeld AND OperandInternal[s] THEN

MimosaLog.ErrorTree[internalCall, s];

subType ¬ SymbolOps.UnderType[SymbolOps.own, OperandType[s]];

WITH procType: seb[subType] SELECT FROM

transfer => {

type ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.transfer.SIZE];

seb[type] ¬ SERecord[mark3: TRUE, mark4: TRUE, body: cons[

align: MimData.bitsToAlignment[Target.bitsPerProcess],

typeInfo: transfer[

mode: process,

safe: procType.safe,

typeIn: RecordSENull,

typeOut: procType.typeOut,

length: Target.bitsPerProcess]]];

IF MimP3S.safety = checked THEN {

CheckArg: Tree.Map = {

argType: Type = OperandType[t];

subType: CSEIndex = SymbolOps.NormalType[SymbolOps.own, argType];

WITH s: seb[subType] SELECT FROM

ref => {IF s.var THEN MimosaLog.ErrorTreeOp[unsafeOp, t, fork]; v ¬ t};

transfer => v ¬ CheckScope[t, argType];

ENDCASE => v ¬ t;

};

tb[subNode].son[1] ¬ CheckScope[s, subType];

tb[subNode].son[2] ¬ UpdateList[tb[subNode].son[2], CheckArg];

};

ENDCASE => ERROR;

tb[subNode].name ¬ fork;

};

apply => type ¬ typeANY;

ENDCASE => {

MimosaLog.ErrorTreeOp[missingOp, tb[subNode].son[1], fork];

type ¬ typeANY;

};

tb[subNode].info ¬ SymbolOps.FromType[type];

RPush[type, attr];

RETURN [[subtree[subNode]]];

};

Monitors

LockVar: PUBLIC PROC [t: Tree.Link] RETURNS [Tree.Link] = {

nDerefs: NAT ¬ 0;

val: Tree.Link ¬ Exp[t, typeANY];

long: BOOL ¬ LongPath[val];

type: Type ¬ RType[];

Dereference: PROC [type: Type] = {

PushTree[val];

PushNode[uparrow, 1];

SetType[type];

SetAttr[2, long];

val ¬ PopTree[];

};

RPop[];

nType: CSEIndex;

IF SymbolOps.EqTypes[SymbolOps.own, type, MimData.typeLOCK] THEN {

IF nDerefs # 0 THEN Dereference[type];

EXIT;

};

type ¬ SymbolOps.TypeRoot[SymbolOps.own, type];

nType ¬ SymbolOps.NormalType[SymbolOps.own, type];

WITH seb[nType] SELECT FROM

record => {

IF monitored THEN {

b: BOOL;

sei: ISEIndex;

desc: ConvertUnsafe.SubString ¬ ["LOCK"L, 0, ("LOCK"L).length];

[b, sei] ¬ SearchCtxList[SymbolOps.EnterString[desc], fieldCtx];

IF ~b THEN {MimosaLog.Error[noAccess]; sei ¬ MimData.seAnon};

PushTree[val];

PushSe[sei];

PushNode[IF nDerefs = 0 THEN dollar ELSE dot, 2];

SetType[MimData.idLOCK];

SetAttr[2, long];

val ¬ PopTree[];

EXIT;

};

GO TO failure;

};

ref => {

IF (nDerefs ¬ nDerefs + 1) > 16 THEN GO TO failure;

long ¬ LongType[type];

IF nDerefs > 1 THEN Dereference[type];

type ¬ refType;

};

ENDCASE => GO TO failure;

REPEAT

failure => MimosaLog.ErrorTreeOp[missingOp, val, lock];

ENDLOOP;

IF OperandLhs[val] = none THEN MimosaLog.ErrorTree[nonLHS, val];

RETURN [val];

};

FindLockParams: PUBLIC PROC RETURNS [formal, actual: ISEIndex ¬ ISENull] = {

node: Tree.Index = GetNode[tb[MimP3.lockNode].son[1]];

IF node # Tree.nullIndex THEN {

formal ¬ FirstId[node];

IF current.inputRecord # RecordSENull THEN {

found: BOOL;

[found, actual] ¬ SearchCtxList[

seb[formal].hash,

seb[current.inputRecord].fieldCtx];

IF ~found THEN actual ¬ ISENull;

};

CopyLock: PUBLIC PROC RETURNS [val: Tree.Link ¬ Tree.Null] = {

formal: ISEIndex ¬ ISENull;

actual: ISEIndex ¬ ISENull;

BindFormal: PROC [sei: ISEIndex] RETURNS [Tree.Link] = {

RETURN [[symbol[index: IF sei = formal THEN actual ELSE sei]]];

};

SELECT TRUE FROM

MimP3.lockNode = Tree.nullIndex => RETURN [Tree.Null];

tb[current.bodyNode].son[4] # Tree.Null =>

val ¬ tb[current.bodyNode].son[4];

ENDCASE => {

[formal: formal, actual: actual] ¬ FindLockParams[];

IF formal # ISENull THEN {

IF actual = ISENull THEN {

MimosaLog.ErrorSei[missingLock, formal];

actual ¬ MimData.seAnon;

};

IF ~Types.Assignable[

[MimData.ownSymbols,
SymbolOps.UnderType[SymbolOps.own, seb[formal].idType]],

[MimData.ownSymbols,
SymbolOps.UnderType[SymbolOps.own, seb[actual].idType]]] THEN

MimosaLog.ErrorSei[typeClash, actual];

};

val ¬ tb[MimP3.lockNode].son[2];

};

val ¬ BindTree[val, BindFormal];

[] ¬ UpdateTreeAttr[val];

};

Signals

Signal: PUBLIC PROC [node: Tree.Index] RETURNS [Tree.Link] = {

nodeTag: Tree.NodeName = tb[node].name;

son1: Tree.Link ¬ SampleAndFree[node, 1];

subNode: Tree.Index ¬ Apply[GetNode[ForceApplication[son1]], typeANY, TRUE];

SELECT tb[subNode].name FROM

signal, signalx => tb[subNode].name ¬ nodeTag;

error, errorx => {

SELECT nodeTag FROM

signal, signalx =>

MimosaLog.ErrorTreeOp[missingOp, tb[subNode].son[1], nodeTag];

ENDCASE;

tb[subNode].name ¬ nodeTag;

};

apply => {};

ENDCASE => MimosaLog.ErrorTree[typeClash, tb[subNode].son[1]];

RETURN [[subtree[subNode]]];

};

ForceApplication: PROC [t: Tree.Link] RETURNS [Tree.Link] = {

IF OpName[t] = apply THEN RETURN [t];

PushTree[t];

PushTree[Tree.Null];

RETURN [MakeNode[apply, 2]];

};

Catch phrases

CatchPhrase: PUBLIC PROC [t: Tree.Link] RETURNS [unwindCaught: BOOL ¬ FALSE] = {

saveReachable: BOOL = current.reachable;

savePathNP: NPUse = pathNP;

saveSafety: Safety = MimP3S.safety;

enclosingSafe: BOOL = (saveSafety = checked);

entryNP, exitNP: NPUse ¬ none;

CatchItem: Tree.Scan = {

node: Tree.Index = GetNode[t];

type: CSEIndex ¬ typeANY;

mixed, safe, error: BOOL ¬ FALSE;

saveIndex: SourceMap.Loc = MimData.textIndex;

CatchLabel: Tree.Map = {

subType: CSEIndex;

oops: BOOL ¬ FALSE;

v ¬ Exp[t, typeANY];

subType ¬ SymbolOps.UnderType[SymbolOps.own, CanonicalType[RType[]]];

RPop[];

entryNP ¬ SequenceNP[entryNP][phraseNP];

WITH t: seb[subType] SELECT FROM

transfer =>

SELECT t.mode FROM

signal, error => {

SELECT TRUE FROM

type = typeANY => type ¬ subType;

NOT Types.Equivalent[
[MimData.ownSymbols, type],
[MimData.ownSymbols, subType]] =>

mixed ¬ TRUE;

ENDCASE;

IF t.safe THEN safe ¬ TRUE;

IF t.mode = error THEN error ¬ TRUE;

};

ENDCASE => oops ¬ TRUE;

SELECT TreeOps.OpName[v] FROM

errorx, signalx => oops ¬ TRUE;

This also checks for errors & signals raised in the selectors

ENDCASE;

IF oops THEN MimosaLog.ErrorTree[typeClash, v];

};

MimData.textIndex ¬ ToLoc[tb[node].info];

tb[node].son[1] ¬ UpdateList[tb[node].son[1], CatchLabel];

IF mixed THEN type ¬ typeANY;

IF type # typeANY AND type # nullType THEN {

RRA: we need to copy the context, perhaps this will work?

type ¬ SymbolOps.CopyXferType[type, TreeOps.IdentityMap];

};

tb[node].son[2] ¬ CatchBody[

tb[node].son[2], type, safe OR (error AND enclosingSafe)];

IF tb[node].son[1] = Tree.Link[symbol[index: MimData.idUNWIND]] THEN {

unwindCaught ¬ TRUE;

IF current.entry AND ~current.unwindEnabled AND current.catchDepth = 0 THEN {

PushTree[tb[node].son[2]]; PushTree[CopyLock[]];

PushNode[unlock, 1]; SetInfo[FromLoc[MimData.textIndex]];

tb[node].son[2] ¬ MakeList[2]}};

tb[node].info ¬ SymbolOps.FromType[IF type # typeANY THEN type ELSE nullType];

MimData.textIndex ¬ saveIndex;

};

CatchBody: PROC
[body: Tree.Link, type: CSEIndex, safe: BOOL] RETURNS [Tree.Link] = {

saveRecord: RecordSEIndex = current.resumeRecord;

saveFlag: BOOL = current.resumeFlag;

inType: CSEIndex ¬ CSENull;

outType: CSEIndex ¬ CSENull;

current.resumeFlag ¬ FALSE;

current.resumeRecord ¬ RecordSENull;

current.catchDepth ¬ current.catchDepth + 1;

WITH t: seb[type] SELECT FROM

transfer => {

inType ¬ t.typeIn;

outType ¬ t.typeOut;

current.resumeFlag ¬ t.mode = signal;

PushArgCtx[inType];

BumpArgRefs[SymbolOps.ArgRecord[SymbolOps.own, inType], TRUE];

current.resumeRecord ¬ SymbolOps.ArgRecord[SymbolOps.own, outType];

PushArgCtx[current.resumeRecord];

ClearRefStack[];

};

ENDCASE;

current.reachable ¬ TRUE;

pathNP ¬ entryNP;

SELECT OpName[body] FROM

block, checked => SetSafety[SafetyAttr[GetNode[body]]];

ENDCASE;

IF safe AND MimP3S.safety = none THEN MimosaLog.Error[unsafeBlock];

body ¬ UpdateList[body, Stmt ! InsertCatchLabel => {IF catchSeen THEN RESUME}];

IF current.resumeRecord # RecordSENull THEN {

We must declare the default resume values. This was left out of previous versions of the compiler, leading to both incorrect code and a safety violation.

FURTHER NOTE! This code inserts a tree already processed by Pass3. Therefore we have to slip it in AFTER we have done the UpdateList operation just above. Otherwise we can see construct, union, and rowcons nodes in MimP3.Exp processing, which is not kosher (results in "unimplemented construct" errors).

ctx: CTXIndex = SymbolOps.ArgCtx[SymbolOps.own, outType];

assigns: Tree.Link = MimP3.AssignDefaults[ctx, FALSE];

bodyName: Tree.NodeName = OpName[body];

SELECT bodyName FROM

block, checked => {

whichSon: NAT = IF bodyName = checked THEN 1 ELSE 2;

bodyNode: Tree.Index ¬ GetNode[body];

PushTree[assigns];

PushTree[tb[bodyNode].son[whichSon]];

PushNode[list, 2];

tb[bodyNode].son[whichSon] ¬ PopTree[];

};

ENDCASE => {

PushTree[assigns];

PushTree[body];

PushNode[list, 2];

body ¬ PopTree[];

};

exitNP ¬ BoundNP[exitNP][pathNP];

WITH t: seb[type] SELECT FROM

transfer => {PopArgCtx[outType]; PopArgCtx[inType]};

ENDCASE;

current.catchDepth ¬ current.catchDepth - 1;

current.resumeRecord ¬ saveRecord;

current.resumeFlag ¬ saveFlag;

SetSafety[saveSafety];

RETURN [body];

};

setLabel, continued: BOOL ¬ FALSE;

node: Tree.Index = GetNode[t];

SealRefStack[];

{

ENABLE InsertCatchLabel => {

IF ~catchSeen THEN {

setLabel ¬ TRUE;

IF exit THEN continued ¬ TRUE;

SIGNAL InsertCatchLabel[catchSeen: TRUE, exit: exit]; RESUME}};

ScanList[tb[node].son[1], CatchItem];

IF tb[node].nSons > 1 THEN

tb[node].son[2] ¬ CatchBody[tb[node].son[2], typeANY, enclosingSafe];

};

IF setLabel THEN {MimP3S.markCatch ¬ TRUE; MimP3S.continued ¬ continued};

UnsealRefStack[];

current.reachable ¬ saveReachable;

phraseNP ¬ exitNP;

pathNP ¬ savePathNP;

};

PushArgCtx: PROC [sei: CSEIndex] = INLINE {

ctx: CTXIndex = SymbolOps.ArgCtx[SymbolOps.own, sei];

IF ctx # CTXNull THEN {

SymbolOps.SetCtxLevel[ctx, current.level + current.catchDepth];

PushCtx[ctx];

};

PopArgCtx: PROC [sei: CSEIndex] = INLINE {

ctx: CTXIndex = SymbolOps.ArgCtx[SymbolOps.own, sei];

IF ctx # CTXNull THEN {

PopCtx[];

SymbolOps.SetCtxLevel[ctx, lZ];

};

Recent utilities

CheckInit: PROC [t: Tree.Link, type: Type, safe: BOOL] RETURNS [Tree.Link] = {

ut: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];

IF NOT AssignableType[ut, FALSE] THEN

SELECT TreeOps.OpName[t] FROM

construct, rowcons => {};

ENDCASE => MimosaLog.ErrorTreeOp[missingOp, t, assign];

SELECT SymbolOps.TypeForm[SymbolOps.own, ut] FROM

$transfer =>

IF MimP3S.safety = checked THEN RETURN [CheckScope[t, ut]];

ENDCASE;

RETURN [t];

};

SampleAndFree: PROC [node: Tree.Index, index: NAT] RETURNS [v: Tree.Link] = INLINE {

v ¬ tb[node].son[index];

tb[node].son[index] ¬ Tree.Null;

FreeNode[node];

};

Rope identification (temporary)

CheckHash: PROC [hti: HTIndex, s: LONG STRING] RETURNS [BOOL] = INLINE {

desc: ConvertUnsafe.SubString = [base: s, offset: 0, length: s.length];

RETURN [SymbolOps.FindString[SymbolOps.own, desc] = hti];

};

TextRep: PUBLIC PROC [rType: Type] RETURNS [form: TextForm ¬ text] = {

type: CSEIndex = SymbolOps.UnderType[SymbolOps.own, rType];

WITH t: seb[type] SELECT FROM

record =>

WITH c: ctxb[t.fieldCtx] SELECT FROM

included => {

IF CheckHash[mdb[c.module].moduleId, "Rope"L] THEN

The type originally comes from the Rope interface

WITH se: seb[rType] SELECT FROM

id => {

SELECT TRUE FROM

CheckHash[se.hash, "RopeRep"L] => RETURN [$rope];

CheckHash[se.hash, "TextRep"L] => RETURN [$ropeText];

ENDCASE;

};

ENDCASE;

};

ENDCASE;

};