Copyright (C) 1994, Digital Equipment Corp. UNSAFE MODULE------------------------------------------------ user callable routines ---RTType EXPORTSRTType ,RTTypeSRC ; IMPORT RT0, RT0u, RTMisc, RTModule, RTHeapRep, M3toC; IMPORT Ctypes, Cstdlib, Cstring, Word; FROM RTIO IMPORT PutInt, PutString, PutText, PutAddr, PutHex, Flush; TYPE TypePtr = UNTRACED REF RT0.TypeDefn;
PROCEDURE--------------------------------------------------- UID -> typecell map ---MaxTypecode (): Typecode = BEGIN RETURN RT0u.nTypes - 1; END MaxTypecode; PROCEDUREIsSubtype (a, b: Typecode): BOOLEAN = VAR t := Get (b); BEGIN IF (a >= RT0u.nTypes) THEN BadType (a) END; IF (a = 0) THEN RETURN TRUE END; RETURN (t.typecode <= a AND a <= t.lastSubTypeTC); END IsSubtype; PROCEDURESupertype (tc: Typecode): Typecode = VAR t := Get (tc); BEGIN IF (t.parent = NIL) THEN RETURN NoSuchType; ELSE RETURN t.parent.typecode; END; END Supertype; PROCEDUREIsTraced (tc: Typecode): BOOLEAN = VAR t := Get (tc); BEGIN RETURN t.traced # 0; END IsTraced; PROCEDUREGet (tc: Typecode): RT0.TypeDefn = VAR p: TypePtr := RT0u.types + tc * ADRSIZE (RT0.TypeDefn); BEGIN IF (tc >= RT0u.nTypes) THEN BadType (tc) END; RETURN p^; END Get; PROCEDUREGetNDimensions (tc: Typecode): CARDINAL = VAR t := Get (tc); BEGIN RETURN t.nDimensions; END GetNDimensions; PROCEDURETypeName (ref: REFANY): TEXT = VAR t := Get (TYPECODE (ref)); BEGIN RETURN TypeDefnToName (t); END TypeName; PROCEDURETypecodeName (tc: Typecode): TEXT = VAR t := Get (tc); BEGIN RETURN TypeDefnToName (t); END TypecodeName; PROCEDURETypeDefnToName (t: RT0.TypeDefn): TEXT = BEGIN IF (t.name = NIL) THEN RETURN "<anon type>"; END; RETURN M3toC.CopyStoT (LOOPHOLE (t.name, Ctypes.char_star)); END TypeDefnToName;
TYPE IDMap = RECORD uid: INTEGER; defn: RT0.TypeDefn END; VAR (* map from type id to typecode, sorted by type id. *) n_type_ids : INTEGER; type_ids : ADDRESS; (* REF ARRAY [0..n_type_ids-1] OF IDMap *) PROCEDURE-------------------------------------------------------- initialization ---FindType (id: INTEGER): RT0.TypeDefn = VAR base : ADDRESS := type_ids; lo : CARDINAL := 0; hi : CARDINAL := n_type_ids; mid : CARDINAL; p : UNTRACED REF IDMap; BEGIN WHILE (lo < hi) DO mid := (lo + hi) DIV 2; p := base + mid * ADRSIZE (p^); IF (id < p.uid) THEN hi := mid; ELSE lo := mid + 1; END; END; IF (lo > 0) THEN DEC (lo) END; p := base + lo * ADRSIZE (p^); IF (p.uid # id) THEN RETURN NIL END; RETURN p.defn; END FindType;
VAR init_done := FALSE; null : RT0.TypeDefn; text : RT0.TypeDefn; root : RT0.TypeDefn; uroot : RT0.TypeDefn; PROCEDURE-------------------------------------------------------- runtime errors ---Init () = BEGIN <* ASSERT NOT init_done *> init_done := TRUE; RegisterTypes (); CheckOpaques (); CheckBrands (); FindChildren (); CheckParents (); AssignTypecodes (); FixLinks (); FixSizes (); CallSetupProcs (); CheckRevelations (); RTHeapRep.CheckTypes (); END Init; PROCEDURERegisterTypes () = (* "register" each typecell with a distinct temporary typecode *) VAR mi : RT0.ModulePtr; t : RT0.TypeDefn; cnt, key : INTEGER; tp, x, y, z : TypePtr; BEGIN (* count the typecells *) cnt := 0; FOR i := 0 TO RT0u.nModules - 1 DO mi := RTModule.Get (i); t := mi.type_cells; WHILE (t # NIL) DO INC (cnt); t := t.next; END; END; (* allocate the space *) RT0u.nTypes := cnt; RT0u.types := Cstdlib.malloc (cnt * BYTESIZE (t)); RT0u.alloc_cnts := Cstdlib.malloc (cnt * BYTESIZE (INTEGER)); RT0u.alloc_bytes := Cstdlib.malloc (cnt * BYTESIZE (INTEGER)); (* initialize the allocation counts *) RTMisc.Zero (RT0u.alloc_cnts, cnt * BYTESIZE (INTEGER)); RTMisc.Zero (RT0u.alloc_bytes, cnt * BYTESIZE (INTEGER)); (* collect pointers to all the typecells *) tp := RT0u.types; FOR i := 0 TO RT0u.nModules - 1 DO mi := RTModule.Get (i); t := mi.type_cells; WHILE (t # NIL) DO tp^ := t; INC (tp, ADRSIZE (t)); t := t.next; END; END; (* sort the cells by uid *) x := RT0u.types; FOR i := 1 TO cnt-1 DO tp := x + i * ADRSIZE (t); t := tp^; key := t.selfID; y := x + (i - 1) * ADRSIZE (t); WHILE (y >= x) AND (y^.selfID > key) DO z := y + ADRSIZE (t); z^ := y^; DEC (y, ADRSIZE (t)); END; z := y + ADRSIZE (t); z^ := t; END; (* remove duplicates, but keep names *) cnt := 1; x := RT0u.types; y := x; FOR i := 1 TO RT0u.nTypes-1 DO INC (y, ADRSIZE (t)); IF x^.selfID = y^.selfID THEN (* a duplicate, if we don't have one yet, save the name *) IF (x^.name = NIL) THEN x^.name := y^.name; END; ELSE (* a new typecell *) INC (cnt); INC (x, ADRSIZE (t)); x^ := y^; END; END; RT0u.nTypes := cnt; END RegisterTypes; PROCEDURECheckOpaques () = (* build the UID->Defn maps including the opaque types *) VAR cnt : INTEGER; mi : RT0.ModulePtr; t : RT0.TypeDefn; r : RT0.RevPtr; s, v: UNTRACED REF IDMap; tp : TypePtr; BEGIN (* count the opaques *) cnt := RT0u.nTypes; FOR i := 0 TO RT0u.nModules - 1 DO mi := RTModule.Get (i); r := mi.full_rev; IF (r # NIL) THEN WHILE (r.lhs_id # 0) DO INC (cnt); INC (r, ADRSIZE (r^)); END; END; END; (* allocate the space *) n_type_ids := cnt; type_ids := Cstdlib.malloc (cnt * BYTESIZE (IDMap)); (* initialize the map with the concrete typecells *) tp := RT0u.types; s := type_ids; FOR i := 0 TO RT0u.nTypes-1 DO t := tp^; s.uid := t.selfID; s.defn := t; INC (tp, ADRSIZE (tp^)); INC (s, ADRSIZE (s^)); END; n_type_ids := RT0u.nTypes; (* finally, add each of the opaque types *) FOR i := 0 TO RT0u.nModules - 1 DO mi := RTModule.Get (i); r := mi.full_rev; IF (r # NIL) THEN WHILE (r.lhs_id # 0) DO t := FindType (r.lhs_id); IF (t # NIL) THEN DuplicateLHS (mi, r, t) END; t := FindType (r.rhs_id); IF (t = NIL) THEN UndefinedRHS (mi, r) END; (* insert the new entry *) v := type_ids + n_type_ids * ADRSIZE (v^); s := v - ADRSIZE (v^); WHILE (s >= type_ids) AND (s.uid > r.lhs_id) DO v^ := s^; DEC (v, ADRSIZE (v^)); DEC (s, ADRSIZE (s^)); END; v.uid := r.lhs_id; v.defn := t; INC (n_type_ids); INC (r, ADRSIZE (r^)); END; END; END; END CheckOpaques; PROCEDURECheckBrands () = (* ensure that all brands are distinct *) VAR t, a, b : RT0.TypeDefn; tp : TypePtr; hash : INTEGER; buckets := ARRAY [0..292] OF RT0.TypeDefn {NIL, ..}; BEGIN (* Hash each type with a non-nil brand into the table using the type's sibling pointer to resolve collisions. *) tp := RT0u.types; FOR i := 0 TO RT0u.nTypes-1 DO t := tp^; IF (t.brand # NIL) THEN hash := HashString (t.brand) MOD NUMBER (buckets); t.sibling := buckets[hash]; buckets[hash] := t; END; INC (tp, ADRSIZE (tp^)); END; (* Run the naive O(n^2) check on each hash bucket. *) FOR i := 0 TO LAST (buckets) DO a := buckets[i]; WHILE (a # NIL) DO b := a.sibling; WHILE (b # NIL) DO IF Cstring.strcmp (LOOPHOLE(a.brand, Ctypes.char_star), LOOPHOLE(b.brand, Ctypes.char_star)) = 0 THEN StartError (); PutText ("Two types have the same brand: \""); PutString (a.brand); PutText ("\"\n*** "); PutType (a); PutText ("\n*** "); PutType (b); EndError (); END; b := b.sibling; END; a := a.sibling; END; END; (* Reset the sibling pointers. *) tp := RT0u.types; FOR i := 0 TO RT0u.nTypes-1 DO tp^.sibling := NIL; INC (tp, ADRSIZE (tp^)); END; END CheckBrands; PROCEDUREHashString (cp: UNTRACED REF CHAR): INTEGER = VAR hash := 0; BEGIN WHILE (cp^ # '\000') DO hash := Word.Plus (Word.LeftShift (hash, 1), ORD (cp^)); INC (cp, BYTESIZE (cp^)); END; RETURN hash; END HashString; PROCEDUREFindChildren () = VAR tp: TypePtr; t, p: RT0.TypeDefn; BEGIN tp := RT0u.types; FOR i := 0 TO RT0u.nTypes -1 DO t := tp^; IF (t.parentID # 0) THEN p := FindType (t.parentID); IF (p = NIL) THEN BadParent (t) END; t.parent := p; t.sibling := p.children; p.children := t; END; INC (tp, ADRSIZE (tp^)); END; END FindChildren; PROCEDURECheckParents () = VAR tp: TypePtr; t, u: RT0.TypeDefn; BEGIN tp := RT0u.types; FOR i := 0 TO RT0u.nTypes -1 DO t := tp^; u := t; WHILE (u # NIL) AND (t # NIL) DO t := t.parent; u := u.parent; IF (u = NIL) THEN EXIT; END; u := u.parent; IF (t = u) THEN ParentCycle (tp^); EXIT; END; END; INC (tp, ADRSIZE (tp^)); END; END CheckParents; PROCEDUREAssignTypecodes () = VAR tp, up : TypePtr; t, u : RT0.TypeDefn; next_typecode : INTEGER; BEGIN (* find the types with reserved typecodes *) null := FindType (16_48ec756e); text := FindType (16_50f86574); root := FindType (16_ffffffff9d8fb489); uroot := FindType (16_ffffffff898ea789); (* reset the typecodes *) tp := RT0u.types; FOR i := 0 TO RT0u.nTypes-1 DO tp^.typecode := LAST (RT0.Typecode); INC (tp, ADRSIZE (tp^)); END; (* assign the fixed typecodes *) null.typecode := RT0.NilTypecode; null.lastSubTypeTC := RT0.NilTypecode; text.typecode := RT0.TextTypecode; text.lastSubTypeTC := RT0.TextTypecode; next_typecode := MAX (RT0.NilTypecode, RT0.TextTypecode) + 1; (* assign the OBJECT typecodes *) AssignObjectTypecode (root, next_typecode); AssignObjectTypecode (uroot, next_typecode); (* assign the remaining REF typecodes *) tp := RT0u.types; FOR i := 0 TO RT0u.nTypes-1 DO t := tp^; IF (t.typecode = LAST (RT0.Typecode)) THEN t.typecode := next_typecode; t.lastSubTypeTC := next_typecode; INC (next_typecode); END; INC (tp, ADRSIZE (tp^)); END; <* ASSERT next_typecode = RT0u.nTypes *> (* shuffle the typecells into their correct slots *) tp := RT0u.types; FOR i := 0 TO RT0u.nTypes-1 DO t := tp^; WHILE (t.typecode # i) DO up := RT0u.types + t.typecode * ADRSIZE (up^); u := up^; up^ := t; t := u; END; tp^ := t; INC (tp, ADRSIZE (tp^)); END; END AssignTypecodes; PROCEDUREAssignObjectTypecode (t: RT0.TypeDefn; VAR next: INTEGER) = VAR u: RT0.TypeDefn; BEGIN <* ASSERT t.typecode = LAST (RT0.Typecode) *> t.typecode := next; INC (next); u := t.children; WHILE (u # NIL) DO AssignObjectTypecode (u, next); u := u.sibling; END; t.lastSubTypeTC := next-1; END AssignObjectTypecode; PROCEDUREFixLinks () = VAR mi : RT0.ModulePtr; t, u : UNTRACED REF RT0.TypeLink; defn : RT0.TypeDefn; BEGIN FOR i := 0 TO RT0u.nModules - 1 DO mi := RTModule.Get (i); t := mi.type_cell_ptrs; WHILE (t # NIL) DO u := t.next; defn := FindType (t.type); IF (defn = NIL) THEN BadTypeId (mi, t.type) END; t.next := defn; t.type := defn.typecode; t := u; END; END; END FixLinks; PROCEDUREFixSizes () = (* fix the data(method) sizes and offsets *) VAR t: RT0.TypeDefn; tp: TypePtr; BEGIN (* make sure that all the REF types are some multiple of header words *) tp := RT0u.types; FOR i := 0 TO RT0u.nTypes-1 DO t := tp^; IF (t.typecode # RT0.NilTypecode) AND (t.parent = NIL) AND (t.children = NIL) THEN t.dataSize := RTMisc.Upper (t.dataSize, BYTESIZE (RTHeapRep.Header)); END; INC (tp, ADRSIZE (tp^)); END; (* fix the objects *) FixObjectSizes (root); FixObjectSizes (uroot); END FixSizes; PROCEDUREFixObjectSizes (t: RT0.TypeDefn) = VAR u: RT0.TypeDefn; BEGIN (* fix my sizes *) u := t.parent; IF (u # NIL) THEN t.dataOffset := RTMisc.Upper (u.dataSize, t.dataAlignment); INC (t.dataSize, t.dataOffset); t.dataAlignment := MAX (t.dataAlignment, u.dataAlignment); t.methodOffset := u.methodSize; INC (t.methodSize, t.methodOffset); END; t.dataSize := RTMisc.Upper (t.dataSize, BYTESIZE (RTHeapRep.Header)); (* allocate my default method list *) t.defaultMethods := Cstdlib.malloc (t.methodSize); IF (t.defaultMethods = NIL) THEN StartError (); PutText ("unable to allocate method suite for "); PutType (t); EndError (); END; RTMisc.Zero (t.defaultMethods, t.methodSize); (* fix my children *) u := t.children; WHILE (u # NIL) DO FixObjectSizes (u); u := u.sibling; END; END FixObjectSizes; PROCEDURECallSetupProcs () = VAR t: RT0.TypeDefn; tp: TypePtr; BEGIN (* set up the REF types *) tp := RT0u.types; FOR i := 0 TO RT0u.nTypes-1 DO t := tp^; IF (t.parent = NIL) AND (t.children = NIL) AND (t.linkProc # NIL) THEN t.linkProc (t); END; INC (tp, ADRSIZE (tp^)); END; (* set up the objects *) SetupObject (root); SetupObject (uroot); END CallSetupProcs; PROCEDURESetupObject (t: RT0.TypeDefn) = VAR u: RT0.TypeDefn; a: UNTRACED REF ADDRESS; BEGIN (* initialize my method suite from my parent *) u := t.parent; IF (u # NIL) THEN RTMisc.Copy (u.defaultMethods, t.defaultMethods, u.methodSize); END; LOOPHOLE (t.defaultMethods, UNTRACED REF INTEGER)^ := t.typecode; (* initialize any remaining methods to the undefined procedure *) a := t.defaultMethods + ADRSIZE (ADDRESS); FOR j := 1 TO t.methodSize DIV BYTESIZE (ADDRESS) - 1 DO IF (a^ = NIL) THEN a^ := LOOPHOLE (UndefinedMethod, ADDRESS) END; INC (a, ADRSIZE (ADDRESS)); END; (* call my setup proc *) IF (t.linkProc # NIL) THEN t.linkProc (t) END; (* set up my children *) u := t.children; WHILE (u # NIL) DO SetupObject (u); u := u.sibling; END; END SetupObject; PROCEDURECheckRevelations () = VAR mi : RT0.ModulePtr; r : RT0.RevPtr; lhs : RT0.TypeDefn; rhs : RT0.TypeDefn; BEGIN FOR i := 0 TO RT0u.nModules - 1 DO mi := RTModule.Get (i); r := mi.partial_rev; IF (r # NIL) THEN WHILE (r.lhs_id # 0) DO lhs := FindType (r.lhs_id); rhs := FindType (r.rhs_id); IF (lhs = NIL) OR (rhs = NIL) OR (lhs.typecode < rhs.typecode) OR (rhs.lastSubTypeTC < lhs.typecode) THEN BadRevelation (mi, r, lhs, rhs); END; INC (r, ADRSIZE (r^)); END; END; END; END CheckRevelations;
PROCEDURE----------------------------------------------------------- init errors ---UndefinedMethod () = BEGIN RTMisc.FatalError (NIL, 0, "attempted invocation of undefined method"); END UndefinedMethod; PROCEDUREBadType (tc: Typecode) = BEGIN RTMisc.FatalErrorI ("improper typecode: ", tc); END BadType;
PROCEDURE---------------------------------------------------- internal debugging ---StartError () = BEGIN PutText ("\n\n***\n*** "); END StartError; PROCEDUREEndError () = BEGIN PutText ("\n***"); Flush (); RTMisc.FatalError (NIL, 0, "unable to initialize runtime types"); END EndError; PROCEDUREBadTypeId (mi: RT0.ModulePtr; id: INTEGER) = BEGIN StartError (); PutText ("unable to resolve type id: "); PutHex (id); PutText ("\n*** in "); PutModule (mi); EndError (); END BadTypeId; PROCEDUREDuplicateLHS (mi: RT0.ModulePtr; r: RT0.RevPtr; t: RT0.TypeDefn) = BEGIN StartError (); PutText ("opaque type redefined: "); PutText ("\n*** REVEAL _t"); PutHex (r.lhs_id); PutText (" = _t"); PutHex (r.rhs_id); PutText ("\n*** in "); PutModule (mi); PutText ("\n*** but, already = "); PutType (t); EndError (); END DuplicateLHS; PROCEDUREUndefinedRHS (mi: RT0.ModulePtr; r: RT0.RevPtr) = BEGIN StartError (); PutText ("opaque type revealed as undefined type: "); PutText ("\n*** REVEAL _t"); PutHex (r.lhs_id); PutText (" = _t"); PutHex (r.rhs_id); PutText ("\n*** in "); PutModule (mi); EndError (); END UndefinedRHS; PROCEDUREBadParent (t: RT0.TypeDefn) = BEGIN StartError (); PutText ("super type undefined:\n*** child = "); PutType (t); PutText ("\n*** parent = _t"); PutHex (t.parentID); EndError (); END BadParent; PROCEDUREParentCycle (t: RT0.TypeDefn) = VAR u: RT0.TypeDefn; BEGIN StartError (); PutText ("illegal cycle in super types:\n*** child = "); PutType (t); u := t.parent; WHILE (u # NIL) DO PutText ("\n*** parent = "); PutType (u); IF (u = t) THEN EXIT; END; u := u.parent; END; EndError (); END ParentCycle; PROCEDUREBadRevelation (mi: RT0.ModulePtr; r: RT0.RevPtr; lhs, rhs: RT0.TypeDefn) = BEGIN StartError (); PutText ("inconsistent partial revelation: "); PutText ("\n*** REVEAL _t"); PutHex (r.lhs_id); PutText (" <: _t"); PutHex (r.rhs_id); PutText ("\n*** "); PutType (lhs); PutText (" <: "); PutType (rhs); PutText ("\n*** in "); PutModule (mi); EndError (); END BadRevelation;
**********************************
PROCEDURE ShowTypes (full := TRUE) =
VAR t: RT0.TypeDefn;
BEGIN
PutText (Here are the types: nTypes =
);
PutInt (RT0u.nTypes);
PutText (\n
);
FOR i := 0 TO RT0u.nTypes-1 DO
t := Get (i);
WHILE (t # NIL) DO
PutType (t); PutText (\n
);
IF full THEN
PutText ( data
);
PutText ( S=
); PutInt (t.dataSize);
PutText ( A=
); PutInt (t.dataAlignment);
PutText ( O=
); PutInt (t.dataOffset);
PutText (\n
);
IF (t.methodSize # 0) OR (t.methodOffset # 0) THEN
PutText ( method
);
PutText ( S=
); PutInt (t.methodSize);
PutText ( O=
); PutInt (t.methodOffset);
PutText (\n
);
END;
IF (t.nDimensions # 0) OR (t.elementSize # 0) THEN
PutText ( array
);
PutText ( D=
); PutInt (t.nDimensions);
PutText ( S=
); PutInt (t.elementSize);
PutText (\n
);
END;
END;
END;
END;
Flush ();
EVAL ShowTypes; (* to prevent an unused symbol
warning
END ShowTypes; ************************************) PROCEDUREPutType (t: RT0.TypeDefn) = BEGIN PutText ("["); PutAddr (t); IF (t # NIL) THEN PutText (" _t"); PutHex (t.selfID); PutText (" typecode= "); PutInt (t.typecode, 3); IF (t.lastSubTypeTC # 0) THEN PutText (" .. "); PutInt (t.lastSubTypeTC, 3); END; IF (t.name # NIL) THEN PutText (" "); PutString (t.name); END; END; PutText ("]"); END PutType; PROCEDUREPutModule (mi: RT0.ModulePtr) = BEGIN IF (mi.file = NIL) THEN PutText ("???"); ELSE PutString (mi.file); END; END PutModule; BEGIN END RTType.