Copyright (C) 1994, Digital Equipment Corp.File: ObjectType.m3
MODULE******** PROCEDURE FieldSize (t: Type.T): INTEGER = VAR p := Confirm (t); BEGIN IF (p = NIL) THEN RETURN Unknown_w_magic END; GetOffsets (p, use_magic := TRUE); IF (p.fieldOffset < 0) THEN RETURN Unknown_w_magic END; RETURN RecordType.RoundUp (p.fieldOffset + p.fieldSize, p.fieldAlign); END FieldSize; **********; IMPORT M3, M3ID, M3String, CG, Type, TypeRep, Scope, Expr, Host; IMPORT Value, Error, RecordType, ProcType, OpaqueType, Revelation; IMPORT Field, Reff, Addr, RefType, Word, TextExpr, M3Buf, ErrType; IMPORT ObjectAdr, ObjectRef, Token, Module, Method; IMPORT AssignStmt, M3RT, Scanner, TipeMap, TipeDesc, TypeFP, Target; FROM Scanner IMPORT Match, GetToken, cur; CONST Unknown_w_magic = -1; Unknown_wo_magic = -2; Unchecked_offset = -3; TYPE P = Type.T BRANDED "ObjectType.T" OBJECT brandE : Expr.T; brand : M3String.T; superType : Type.T; fields : Scope.T; fieldOffset : INTEGER; fieldSize : INTEGER; fieldAlign : INTEGER; methods : Scope.T; methodSize : INTEGER; methodOffset : INTEGER; overrideSize : INTEGER; tc_module : Module.T; inPrimLookUp : BOOLEAN; isTraced : BOOLEAN; user_name : TEXT; OVERRIDES check := Check; check_align:= CheckAlign; isEqual := EqualChk; isSubtype := Subtyper; compile := Compiler; initCost := InitCoster; initValue := TypeRep.InitToZeros; mapper := TypeRep.GenRefMap; gen_desc := TypeRep.GenRefDesc; fprint := FPrinter; END; VAR NIL_ID: INTEGER := 0; ROOT_ID: INTEGER := 0; UROOT_ID: INTEGER := 0; PROCEDURE ObjectType Parse (sup: Type.T; traced: BOOLEAN; brand: Expr.T): Type.T = TYPE TK = Token.T; VAR p: P; BEGIN LOOP p := New (sup, traced, brand, NIL, NIL); Match (TK.tOBJECT); p.fields := Scope.PushNew (FALSE, M3ID.NoID); RecordType.ParseFieldList (); Scope.PopNew (); p.methods := Scope.PushNew (FALSE, M3ID.NoID); IF (cur.token = TK.tMETHODS) THEN GetToken (); (* METHODS *) p.methodSize := ParseMethodList (p, overrides := FALSE); END; IF (cur.token = TK.tOVERRIDES) THEN GetToken (); (* OVERRIDES *) p.overrideSize := ParseMethodList (p, overrides := TRUE); END; Scope.PopNew (); Match (TK.tEND); brand := RefType.ParseBrand (); IF (cur.token # TK.tOBJECT) THEN IF (brand # NIL) THEN Error.Msg ("dangling brand") END; EXIT; END; sup := p; traced := FALSE; END; RETURN p; END Parse; PROCEDUREParseMethodList (p: P; overrides := FALSE): INTEGER = TYPE TK = Token.T; VAR info: Method.Info; BEGIN info.offset := 0; info.parent := p; info.override := overrides; WHILE (cur.token = TK.tIDENT) DO info.name := cur.id; GetToken (); (* ID *) info.signature := NIL; IF (cur.token = TK.tLPAREN) THEN info.signature := ProcType.ParseSignature (M3ID.NoID, Target.DefaultCall); END; info.dfault := NIL; IF (cur.token = TK.tEQUAL) THEN Error.Msg ("default value must begin with ':='"); cur.token := TK.tASSIGN; END; IF cur.token = TK.tASSIGN THEN GetToken (); (* := *) info.dfault := Expr.Parse (); END; IF overrides THEN IF info.signature # NIL THEN Error.ID (info.name, "overrides cannot have a signature"); ELSIF info.dfault = NIL THEN Error.ID (info.name, "missing default value in method override"); END; ELSE IF info.signature = NIL THEN Error.ID (info.name, "missing method signature (old override?)"); END; IF (info.signature = NIL) AND (info.dfault = NIL) THEN Error.ID (info.name, "methods must include a signature or default value"); END; END; EVAL Method.New (info); INC (info.offset, Target.Address.size); IF (cur.token # TK.tSEMI) THEN EXIT END; GetToken (); (* ; *) END; RETURN info.offset; END ParseMethodList; PROCEDURENew (super: Type.T; traced: BOOLEAN; brand: Expr.T; fields, methods: Scope.T): Type.T = VAR p: P; BEGIN IF (super = NIL) THEN IF (traced) THEN super := ObjectRef.T; ELSE super := ObjectAdr.T; END; END; p := NEW (P); TypeRep.Init (p, Type.Class.Object); p.isTraced := traced; p.brandE := brand; p.brand := NIL; p.superType := super; p.fields := fields; p.fieldOffset := Unchecked_offset; p.fieldSize := -1; p.fieldAlign := -1; p.methods := methods; p.methodSize := 0; p.methodOffset := Unchecked_offset; p.overrideSize := 0; p.tc_module := NIL; p.inPrimLookUp := FALSE; p.user_name := NIL; RETURN p; END New; PROCEDUREIs (t: Type.T): BOOLEAN = VAR m: Revelation.TypeList; u: Type.T; x: Revelation.TypeSet; BEGIN IF (t = NIL) THEN RETURN FALSE END; IF (t.info.class = Type.Class.Named) THEN t := Type.Strip (t); END; (* try for TYPE t = OBJECT ... END *) IF (t.info.class = Type.Class.Object) THEN RETURN TRUE END; IF (t.info.class # Type.Class.Opaque) THEN RETURN FALSE END; (* try for TYPE t <: ObjectType *) u := OpaqueType.Super (t); IF Is (u) THEN RETURN TRUE END; (*************** (* try for REVEAL t = OBJECT ... END *) u := Revelation.LookUp (t); IF (u # NIL) AND (u.class = Type.Class.Object) THEN RETURN TRUE END; ********************) Revelation.LookUpAll (t, x); (* try for REVEAL t <: OBJECT ... END *) FOR i := 0 TO x.cnt-1 DO u := Type.Strip (x.types[i]); IF (u # NIL) AND (u.info.class = Type.Class.Object) THEN RETURN TRUE END; END; m := x.others; WHILE (m # NIL) DO u := Type.Strip (m.type); IF (u # NIL) AND (u.info.class = Type.Class.Object) THEN RETURN TRUE END; m := m.next; END; (* try for REVEAL t <: U where U is an object type *) FOR i := 0 TO x.cnt-1 DO IF Is (x.types[i]) THEN RETURN TRUE END; END; m := x.others; WHILE (m # NIL) DO IF Is (m.type) THEN RETURN TRUE END; m := m.next; END; RETURN FALSE; END Is; PROCEDUREIsBranded (t: Type.T): BOOLEAN = VAR info: Type.Info; BEGIN t := Type.CheckInfo (t, info); IF (info.class # Type.Class.Object) THEN RETURN FALSE END; (* try for TYPE t = BRANDED OBJECT ... END *) IF (info.class = Type.Class.Object) THEN RETURN (NARROW (t, P).brand # NIL); END; IF (info.class # Type.Class.Opaque) THEN RETURN FALSE END; (* try for REVEAL t = BRANDED OBJECT ... END *) t := Revelation.LookUp (t); IF (t = NIL) THEN RETURN FALSE END; t := Type.CheckInfo (t, info); IF (info.class = Type.Class.Object) THEN RETURN (NARROW (t, P).brand # NIL); END; RETURN FALSE; END IsBranded; PROCEDURESuper (t: Type.T): Type.T = VAR info: Type.Info; BEGIN t := Type.CheckInfo (t, info); IF (info.class # Type.Class.Object) THEN RETURN NIL END; RETURN NARROW (t, P).superType; END Super; PROCEDURELookUp (t: Type.T; id: M3ID.T; VAR value: Value.T; VAR visible: Type.T): BOOLEAN = VAR p: P; v: Value.T; z: Type.T; info: Type.Info; x: Revelation.TypeSet; BEGIN LOOP t := Type.CheckInfo (t, info); IF (info.class = Type.Class.Error) THEN value := NIL; visible := ErrType.T; RETURN FALSE; ELSIF (info.class = Type.Class.Object) THEN (* found an object type => try it! *) p := t; v := Scope.LookUp (p.methods, id, TRUE); IF (v # NIL) THEN (* find the first non-override declaration for this method *) p := PrimaryMethodDeclaration (p, v); IF (p = NIL) THEN RETURN FALSE END; ELSE (* try for a field *) v := Scope.LookUp (p.fields, id, TRUE); END; IF (v # NIL) THEN value := v; visible := p; RETURN TRUE; END; t := p.superType; ELSIF (info.class = Type.Class.Opaque) THEN (* try any revelations that are visible *) z := Revelation.LookUp (t); IF (z # NIL) THEN (* use the concrete type *) t := z; ELSE (* try any subtype revelations that are visible *) Revelation.LookUpAll (t, x); FOR i := 0 TO x.cnt-1 DO IF LookUp(x.types[i], id, value, visible) THEN RETURN TRUE; END; END; WHILE (x.others # NIL) DO IF LookUp(x.others.type, id, value, visible) THEN RETURN TRUE; END; x.others := x.others.next; END; t := OpaqueType.Super (t); END; ELSE (* ??? *) RETURN FALSE; END; END; (* LOOP *) END LookUp; PROCEDUREPrimaryMethodDeclaration (p: P; v: Value.T): P = VAR method: Method.Info; visible: Type.T; obj: Value.T; BEGIN Method.SplitX (v, method); IF NOT method.override THEN RETURN p END; IF p.inPrimLookUp THEN Error.Msg ("illegal recursive supertype"); ELSE p.inPrimLookUp := TRUE; IF LookUp (p.superType, method.name, obj, visible) THEN p.inPrimLookUp := FALSE; RETURN visible; END; p.inPrimLookUp := FALSE; END; RETURN NIL; END PrimaryMethodDeclaration; PROCEDURECheck (p: P) = VAR super : Type.T; brand : Expr.T; name : M3ID.T; n : INTEGER; o, v : Value.T; t1 : Type.T; hash : INTEGER; method : Method.Info; cs := M3.OuterCheckState; super_info : Type.Info; BEGIN hash := 0; (* check out my super type *) super := p.superType; IF (super # NIL) THEN (* some super type specified *) super := Type.CheckInfo (super, super_info); p.superType := super; IF Is (super) THEN (* super type is an object type *) p.isTraced := super_info.isTraced; hash := Word.Times (super_info.hash, 37); IF (super = p) THEN Error.Msg ("illegal recursive supertype"); super := NIL; p.superType := NIL; END; ELSE (* super type isn't an object! *) Error.Msg ("super type must be an object type"); p.superType := NIL; p.isTraced := super_info.isTraced; END; END; IF (p.brandE # NIL) THEN Expr.TypeCheck (p.brandE, cs); brand := Expr.ConstValue (p.brandE); IF (brand = NIL) THEN Error.Msg ("brand is not a constant"); ELSIF TextExpr.Split (brand, p.brand) THEN hash := Word.Plus (Word.Times (hash, 37), M3String.Hash (p.brand)); RefType.NoteBrand (p, p.brand); ELSE Error.Msg ("brand is not a TEXT constant"); END; END; (* include the fields in my hash value *) o := Scope.ToList (p.fields); n := 0; WHILE (o # NIL) DO name := Value.CName (o); hash := Word.Plus (Word.Times (hash, 23), M3ID.Hash (name)); hash := Word.Plus (Word.Times (hash, 23), n); IF (Scope.LookUp (p.methods, name, TRUE) # NIL) THEN Error.ID (name, "field and method with the same name"); END; o := o.next; INC (n); END; (* include the methods in my hash value *) o := Scope.ToList (p.methods); WHILE (o # NIL) DO name := Value.CName (o); hash := Word.Plus (Word.Times (hash, 23), M3ID.Hash (name)); hash := Word.Plus (Word.Times (hash, 23), 617); o := o.next; END; p.info.size := Target.Address.size; p.info.min_size := Target.Address.size; p.info.alignment := Target.Address.align; p.info.mem_type := CG.Type.Addr; p.info.stk_type := CG.Type.Addr; p.info.class := Type.Class.Object; p.info.isTraced := p.isTraced; p.info.isEmpty := FALSE; p.info.isSolid := TRUE; p.info.hash := hash; INC (Type.recursionDepth); (*------------------------------------*) p.checked := TRUE; (* bind method overrides to their original declarations *) o := Scope.ToList (p.methods); WHILE (o # NIL) DO Method.SplitX (o, method); IF (method.override) THEN IF LookUp (super, method.name, v, t1) AND Method.Split (v, method) THEN Method.NoteOverride (o, v); ELSE Scanner.offset := o.origin; Error.ID (method.name, "no method to override in supertype"); END; END; o := o.next; END; (* checkout my fields & methods *) Scope.TypeCheck (p.fields, cs); Scope.TypeCheck (p.methods, cs); DEC (Type.recursionDepth); (*------------------------------------*) (* compute the size & alignment requirements of my fields *) GetSizes (p); IF (NOT p.isTraced) AND Module.IsSafe() THEN CheckTracedFields (p) END; END Check; PROCEDURECheckAlign (<*UNUSED*> p: P; offset: INTEGER): BOOLEAN = BEGIN RETURN (offset MOD Target.Address.align = 0); END CheckAlign; PROCEDURECheckTracedFields (p: P) = VAR v := Scope.ToList (p.fields); info: Type.Info; BEGIN WHILE (v # NIL) DO EVAL Type.CheckInfo (Value.TypeOf (v), info); IF info.isTraced THEN Error.ID (Value.CName (v), "unsafe: untraced object contains a traced field"); END; v := v.next; END; END CheckTracedFields; PROCEDURECompiler (p: P) = VAR fields, methods, v: Value.T; brand: TEXT := NIL; nFields, nMethods, nOverrides: INTEGER; BEGIN Type.Compile (p.superType); fields := Scope.ToList (p.fields); methods := Scope.ToList (p.methods); (* count the fields & methods *) v := fields; nFields := 0; WHILE (v # NIL) DO INC (nFields); v := v.next; END; nMethods := p.methodSize DIV Target.Address.size; nOverrides := p.overrideSize DIV Target.Address.size; (* declare my field and method types *) GenMethods (methods, FALSE); GenOverrides (methods, FALSE); GenFields (fields, FALSE); (* declare myself, my fields, and my methods *) IF (p.brand # NIL) THEN brand := M3String.ToText (p.brand) END; CG.Declare_object (Type.GlobalUID (p), Type.GlobalUID (p.superType), brand, p.isTraced, nFields, nMethods, nOverrides, p.fieldSize); GenMethods (methods, TRUE); GenOverrides (methods, TRUE); GenFields (fields, TRUE); (* YUCK! m3gdb assumes the methods are declared first. *) END Compiler; PROCEDUREGenFields (fields: Value.T; declare: BOOLEAN) = BEGIN WHILE (fields # NIL) DO IF (declare) THEN Field.EmitDeclaration (fields); ELSE Type.Compile (Value.TypeOf (fields)); END; fields := fields.next; END; END GenFields; PROCEDUREGenMethods (methods: Value.T; declare: BOOLEAN) = VAR method: Method.Info; BEGIN WHILE (methods # NIL) DO Method.SplitX (methods, method); IF (method.override) THEN (* skip *) ELSIF (declare) THEN CG.Declare_method (method.name, Type.GlobalUID (method.signature), method.dfault); ELSE Type.Compile (method.signature); END; methods := methods.next; END; END GenMethods; PROCEDUREGenOverrides (methods: Value.T; declare: BOOLEAN) = VAR method: Method.Info; BEGIN WHILE (methods # NIL) DO Method.SplitX (methods, method); IF (method.override) AND (declare) THEN CG.Declare_override (method.name, method.dfault); END; methods := methods.next; END; END GenOverrides; PROCEDURENoteOffsets (t: Type.T; pp: Type.T) = VAR p := Confirm (pp); BEGIN IF (p = NIL) THEN (* not an object *) RETURN END; GetOffsets (p, use_magic := NOT Module.IsInterface ()); Host.env.note_opaque_magic (Type.GlobalUID (t), Type.GlobalUID (p.superType), p.fieldSize, p.fieldAlign, p.methodSize); END NoteOffsets; PROCEDURENoteRefName (t: Type.T; name: TEXT) = VAR p := Confirm (t); BEGIN IF (p # NIL) THEN p.user_name := name; END; END NoteRefName; PROCEDUREInitTypecell (t: Type.T; offset, prev: INTEGER) = VAR p : P := t; fields := Scope.ToList (p.fields); type_map := GenTypeMap (p, fields, refs_only := FALSE); gc_map := GenTypeMap (p, fields, refs_only := TRUE); type_desc := GenTypeDesc (p, fields); initProc := GenInitProc (p); linkProc := GenLinkProc (p); brand : INTEGER := 0; super_id : INTEGER := 0; isz : INTEGER := Target.Integer.size; name_offs : INTEGER := 0; fp := TypeFP.FromType (p); globals := Module.GlobalData (NIL); BEGIN IF (p.superType # NIL) THEN super_id := Type.GlobalUID (p.superType) END; IF (p.brand # NIL) THEN brand := Module.Allocate (8 * (M3String.Length (p.brand) + 1), Target.Char.align, "brand"); M3String.Init_chars (brand, p.brand); END; IF (p.user_name # NIL) THEN name_offs := CG.EmitText (p.user_name); END; (* generate my Type cell info *) CG.Init_intt (offset + M3RT.TC_selfID, isz, Type.GlobalUID (p)); FOR i := FIRST (fp.byte) TO LAST (fp.byte) DO CG.Init_intt (offset + M3RT.TC_fp + i * 8, 8, fp.byte[i]); END; IF (p.isTraced) THEN CG.Init_intt (offset + M3RT.TC_traced, isz, 1); END; CG.Init_intt (offset + M3RT.TC_dataSize, isz, p.fieldSize DIV Target.Byte); CG.Init_intt (offset + M3RT.TC_dataAlignment, isz, p.fieldAlign DIV Target.Byte); CG.Init_intt (offset + M3RT.TC_methodSize, isz, p.methodSize DIV Target.Byte); IF (type_map > 0) THEN CG.Init_var (offset + M3RT.TC_type_map, globals, type_map); END; IF (gc_map > 0) THEN CG.Init_var (offset + M3RT.TC_gc_map, globals, gc_map); END; IF (type_desc > 0) THEN CG.Init_var (offset + M3RT.TC_type_desc, globals, type_desc); END; CG.Init_intt (offset + M3RT.TC_parentID, isz, super_id); IF (initProc # NIL) THEN CG.Init_proc (offset + M3RT.TC_initProc, initProc); END; IF (linkProc # NIL) THEN CG.Init_proc (offset + M3RT.TC_linkProc, linkProc); END; IF (brand # 0) THEN CG.Init_var (offset + M3RT.TC_brand, globals, brand); END; IF (p.user_name # NIL) THEN CG.Init_var (offset + M3RT.TC_name, globals, name_offs); END; IF (prev # 0) THEN CG.Init_var (offset + M3RT.TC_next, globals, prev); END; NoteOffsets (p, p); END InitTypecell; PROCEDUREGenTypeMap (p: P; fields: Value.T; refs_only: BOOLEAN): INTEGER = (* generate my "TypeMap" (called by the garbage collector) *) VAR field: Field.Info; BEGIN TipeMap.Start (); WHILE (fields # NIL) DO Field.Split (fields, field); Type.GenMap (field.type, field.offset, -1, refs_only); fields := fields.next; END; RETURN TipeMap.Finish ("type map for ", Type.Name (p)); END GenTypeMap; PROCEDUREGenTypeDesc (p: P; fields: Value.T): INTEGER = (* generate my "TypeDesc" (called by the pickle machinery) *) VAR field: Field.Info; nFields := 0; v := fields; BEGIN IF NOT p.isTraced THEN RETURN -1 END; TipeDesc.Start (); IF TipeDesc.AddO (TipeDesc.Op.Object, p) THEN (* count the fields *) WHILE (v # NIL) DO INC (nFields); v := v.next; END; TipeDesc.AddI (nFields); WHILE (fields # NIL) DO Field.Split (fields, field); Type.GenDesc (field.type); fields := fields.next; END; END; RETURN TipeDesc.Finish ("type description for ", Type.Name (p)); END GenTypeDesc; PROCEDUREGenInitProc (p: P): CG.Proc = VAR v := Scope.ToList (p.fields); field : Field.Info; ptr : CG.Val; obj : CG.Var; done : BOOLEAN := TRUE; name : TEXT := NIL; proc : CG.Proc := NIL; BEGIN (* check to see if we need any initialization code *) WHILE (v # NIL) DO Field.Split (v, field); IF (field.dfault = NIL) THEN IF Type.InitCost (field.type, TRUE) # 0 THEN done := FALSE; EXIT; END; ELSIF NOT Expr.IsZeroes (field.dfault) THEN done := FALSE; EXIT; END; v := v.next; END; IF (done) THEN RETURN NIL; END; (* generate the procedure body *) name := Module.Prefix (NIL) & Type.Name (p) & "_INIT"; CG.Comment (-1, name); Scanner.offset := p.origin; CG.Gen_location (p.origin); proc := CG.Declare_procedure (M3ID.Add (name), 1, CG.Type.Void, 0, Target.DefaultCall, exported:= FALSE, parent := NIL); obj := CG.Declare_param (M3ID.NoID, Target.Address.size, Target.Address.align, CG.Type.Addr, Type.GlobalUID (p), in_memory := FALSE, up_level := FALSE, f := CG.Always); CG.Begin_procedure (proc); (* allocate and initialize a pointer to the data fields *) CG.Load_addr (obj); IF (p.fieldOffset >= 0) THEN (* the field offsets are constant *) CG.Add_offset (p.fieldOffset); ELSE (* the field offsets are unknown *) Type.LoadInfo (p, M3RT.TC_dataOffset); CG.Index_bytes (Target.Byte); END; ptr := CG.Pop (); (* initialize each of the fields *) v := Scope.ToList (p.fields); WHILE (v # NIL) DO Field.Split (v, field); IF (field.dfault = NIL) THEN IF Type.InitCost (field.type, TRUE) > 0 THEN CG.Push (ptr); CG.Boost_alignment (p.fieldAlign); CG.Add_offset (field.offset); Type.InitValue (field.type, TRUE); END; ELSIF NOT Expr.IsZeroes (field.dfault) THEN AssignStmt.PrepForEmit (field.type, field.dfault, initializing := TRUE); CG.Push (ptr); CG.Boost_alignment (p.fieldAlign); CG.Add_offset (field.offset); AssignStmt.Emit (field.type, field.dfault); END; v := v.next; END; CG.Free (ptr); CG.Exit_proc (CG.Type.Void); CG.End_procedure (proc); RETURN proc; END GenInitProc; PROCEDUREGenLinkProc (p: P): CG.Proc = VAR v := Scope.ToList (p.methods); method : Method.Info; top : Value.T; tVisible : Type.T; t_default : Type.T; ptr : CG.Val; b : BOOLEAN; m_offset : INTEGER; done : BOOLEAN := TRUE; name : TEXT := NIL; proc : CG.Proc := NIL; BEGIN (* check to see if we need any setup code *) WHILE (v # NIL) DO Method.SplitX (v, method); IF (method.dfault # NIL) THEN done := FALSE; EXIT; END; v := v.next; END; IF (done) THEN RETURN NIL; END; Type.GenTag (p, "link-time setup code for ", -1); (* get a pointer to my default method list *) name := Module.Prefix (NIL) & Type.Name (p) & "_LINK"; CG.Comment (-1, name); Scanner.offset := p.origin; CG.Gen_location (p.origin); proc := CG.Declare_procedure (M3ID.Add (name), 0, CG.Type.Void, 0, Target.DefaultCall, exported:= FALSE, parent := NIL); CG.Begin_procedure (proc); Type.LoadInfo (p, M3RT.TC_defaultMethods, addr := TRUE); ptr := CG.Pop (); v := Scope.ToList (p.methods); WHILE (v # NIL) DO Method.SplitX (v, method); IF (method.dfault # NIL) THEN t_default := Expr.TypeOf (method.dfault); b := LookUp (p, method.name, top, tVisible); <* ASSERT b *> AssignStmt.PrepForEmit (t_default, method.dfault, initializing := TRUE); CG.Push (ptr); CG.Boost_alignment (Target.Address.align); CG.Add_offset (method.offset); m_offset := MethodOffset (tVisible); IF (m_offset >= 0) THEN CG.Add_offset (m_offset); ELSE Type.LoadInfo (tVisible, M3RT.TC_methodOffset); CG.Index_bytes (Target.Byte); END; CG.Boost_alignment (Target.Address.align); AssignStmt.Emit (t_default, method.dfault); END; v := v.next; END; CG.Free (ptr); CG.Exit_proc (CG.Type.Void); CG.End_procedure (proc); RETURN proc; END GenLinkProc; PROCEDUREEqualChk (a: P; t: Type.T; x: Type.Assumption): BOOLEAN = VAR b: P := t; xa, xb: Value.T; BEGIN IF (a = NIL) OR (a.isTraced # b.isTraced) OR (a.brand # b.brand) OR (NOT Type.IsEqual (a.superType, b.superType, x)) THEN RETURN FALSE; END; (* check the fields *) xa := Scope.ToList (a.fields); xb := Scope.ToList (b.fields); WHILE (xa # NIL) AND (xb # NIL) DO IF NOT Field.IsEqual (xa, xb, x) THEN RETURN FALSE END; xa := xa.next; xb := xb.next; END; IF (xa # NIL) OR (xb # NIL) THEN RETURN FALSE END; (* check the methods *) xa := Scope.ToList (a.methods); xb := Scope.ToList (b.methods); WHILE (xa # NIL) AND (xb # NIL) DO IF NOT Method.IsEqual (xa, xb, x) THEN RETURN FALSE END; xa := xa.next; xb := xb.next; END; IF (xa # NIL) OR (xb # NIL) THEN RETURN FALSE END; RETURN TRUE; END EqualChk; PROCEDURESubtyper (a: P; t: Type.T): BOOLEAN = VAR root := Reff.T; BEGIN IF (NOT a.isTraced) THEN root := Addr.T END; IF Type.IsEqual (t, root, NIL) THEN RETURN TRUE END; RETURN Type.IsEqual (a, t, NIL) OR ((a.superType # NIL) AND Type.IsSubtype (a.superType, t)); END Subtyper; PROCEDUREInitCoster (<*UNUSED*> p: P; zeroed: BOOLEAN): INTEGER = BEGIN IF (zeroed) THEN RETURN 0 ELSE RETURN 1 END; END InitCoster; PROCEDUREFPrinter (p: P; VAR x: M3.FPInfo) = VAR v: Value.T; n: INTEGER; BEGIN IF Type.IsEqual (p, ObjectRef.T, NIL) THEN x.tag := "$objectref"; x.n_nodes := 0; ELSIF Type.IsEqual (p, ObjectAdr.T, NIL) THEN x.tag := "$objectadr"; x.n_nodes := 0; ELSE M3Buf.PutText (x.buf, "OBJECT"); IF (NOT p.isTraced) THEN M3Buf.PutText (x.buf, "-UNTRACED") END; IF (p.brand # NIL) THEN M3Buf.PutText (x.buf, "-BRAND "); M3Buf.PutInt (x.buf, M3String.Length (p.brand)); M3Buf.PutChar (x.buf, ' '); M3String.Put (x.buf, p.brand); END; (* count the children *) n := 1; (* for supertype *) v := Scope.ToList (p.fields); WHILE (v # NIL) DO INC (n, Value.AddFPTag (v, x)); v := v.next; END; v := Scope.ToList (p.methods); IF (v # NIL) THEN M3Buf.PutText (x.buf, " METHODS"); WHILE (v # NIL) DO INC (n, Value.AddFPTag (v, x)); v := v.next; END; END; x.n_nodes := n; (* add the children *) IF (n <= NUMBER (x.nodes)) THEN x.nodes[0] := p.superType; n := 1; ELSE x.others := NEW (REF ARRAY OF Type.T, n); x.others[0] := p.superType; n := 1; END; v := Scope.ToList (p.fields); WHILE (v # NIL) DO n := Value.AddFPEdges (v, x, n); v := v.next; END; v := Scope.ToList (p.methods); WHILE (v # NIL) DO n := Value.AddFPEdges (v, x, n); v := v.next; END; END; END FPrinter; PROCEDUREMethodOffset (t: Type.T): INTEGER = VAR p := Confirm (t); BEGIN IF (p = NIL) THEN RETURN Unknown_w_magic END; GetOffsets (p, use_magic := TRUE); RETURN p.methodOffset; END MethodOffset; PROCEDUREGetFieldOffset (t: Type.T; VAR offset, align: INTEGER) = VAR p := Confirm (t); BEGIN IF (p = NIL) THEN offset := Unknown_w_magic; align := Target.Byte; ELSE GetOffsets (p, use_magic := TRUE); offset := p.fieldOffset; align := p.fieldAlign; END; END GetFieldOffset; PROCEDUREFieldAlignment (t: Type.T): INTEGER = VAR p := Confirm (t); BEGIN IF (p = NIL) THEN RETURN Target.Byte END; GetSizes (p); RETURN p.fieldAlign; END FieldAlignment;
PROCEDUREGetSizes (p: P) = VAR solid: BOOLEAN; BEGIN IF (p.fieldSize >= 0) THEN (* already done *) RETURN END; IF (p.superType = NIL) THEN (* p is ROOT or UNTRACED ROOT *) p.fieldSize := 0; p.fieldAlign := Target.Address.align; ELSE (* compute the field sizes and alignments *) RecordType.SizeAndAlignment (p.fields, p.fieldSize, p.fieldAlign, solid); (* round the object's size up to at least the size of a heap header *) p.fieldSize := RecordType.RoundUp (p.fieldSize, Target.Address.size); END; END GetSizes; PROCEDUREGetOffsets (p: P; use_magic: BOOLEAN) = VAR super: P; d_size, m_size: INTEGER; BEGIN IF (p.fieldOffset >= 0) THEN (* already done *) RETURN; ELSIF (p.fieldOffset = Unchecked_offset) THEN (* we haven't tried yet *) ELSIF (p.fieldOffset = Unknown_w_magic) THEN (* we've tried everything already *) RETURN; ELSIF (NOT use_magic) THEN (* we've already tried it without magic *) RETURN; END; GetSizes (p); IF (p.superType = NIL) THEN (* p is ROOT or UNTRACED ROOT *) p.fieldOffset := Target.Address.size; p.methodOffset := Target.Integer.size; ELSE IF (use_magic) THEN p.fieldOffset := Unknown_w_magic; p.methodOffset := Unknown_w_magic; ELSE p.fieldOffset := Unknown_wo_magic; p.methodOffset := Unknown_wo_magic; END; (* try to get my supertype's offset *) super := Confirm (p.superType); IF (super # NIL) THEN (* supertype is visible *) GetOffsets (super, use_magic); IF (super.fieldOffset >= 0) THEN p.fieldOffset := super.fieldOffset + super.fieldSize; p.fieldOffset := RecordType.RoundUp (p.fieldOffset, p.fieldAlign); p.methodOffset := super.methodOffset + super.methodSize; END; ELSIF (use_magic) AND FindMagic (Type.GlobalUID (p.superType), d_size, m_size) THEN p.fieldOffset := RecordType.RoundUp (d_size, p.fieldAlign); p.methodOffset := m_size; END; END; END GetOffsets; PROCEDUREFindMagic (t_id: INTEGER; VAR d_size, m_size: INTEGER): BOOLEAN = VAR super, my_d_size, my_d_align, my_m_size, s_d_size, s_m_size: INTEGER; BEGIN IF (NIL_ID = 0) THEN NIL_ID := Type.GlobalUID (NIL); ROOT_ID := Type.GlobalUID (ObjectRef.T); UROOT_ID := Type.GlobalUID (ObjectAdr.T); END; IF (t_id = NIL_ID) OR (t_id = ROOT_ID) OR (t_id = UROOT_ID) THEN d_size := Target.Address.size; m_size := Target.Integer.size; RETURN TRUE; ELSIF NOT Host.env.find_opaque_magic (t_id, super, my_d_size, my_d_align, my_m_size) THEN RETURN FALSE; ELSIF NOT FindMagic (super, s_d_size, s_m_size) THEN RETURN FALSE; ELSE (* we did it! *) d_size := s_d_size + my_d_size; d_size := RecordType.RoundUp (d_size, my_d_align); m_size := s_m_size + my_m_size; RETURN TRUE; END; END FindMagic; PROCEDUREConfirm (t: Type.T): P = VAR info: Type.Info; BEGIN LOOP t := Type.CheckInfo (t, info); IF (info.class = Type.Class.Object) THEN RETURN t; ELSIF (info.class = Type.Class.Opaque) THEN t := Revelation.LookUp (t); ELSE RETURN NIL; END; END; END Confirm; BEGIN END ObjectType.