Copyright (C) 1994, Digital Equipment Corp.File: TypeFP.m3
MODULE; IMPORT Text, Convert; IMPORT M3, M3FP, M3Buf, Host, Type, TypeRep, ErrType; TypeFP
The scc_id field of an Node n is used as follows:
= NO_SCC => the n has never been visited
> NO_SCC => the n is done, its fingerprint is in n.fp
< NO_SCC => the n is on the active stack, stack[-n.scc_id] is its entry.
CONST
DFS_not_visited = 0;
DFS_reset = DFS_not_visited + 1;
NO_SCC = TypeRep.NO_SCC;
TYPE
Node = Type.T;
Info = RECORD
node : Node;
info : M3.FPInfo;
dfs_id : INTEGER;
END;
TYPE
IntList = REF ARRAY OF INTEGER;
TypeList = REF ARRAY OF Type.T;
VAR n_reps : INTEGER := 0;
VAR reps : TypeList := NIL;
VAR hash_table : IntList := NIL;
VAR stack : REF ARRAY OF Info;
VAR tos : INTEGER := NO_SCC + 1;
VAR dfs_cnt : INTEGER := DFS_reset;
VAR next_scc : INTEGER := NO_SCC + 1;
VAR mbuf : M3Buf.T := NIL;
VAR busy : BOOLEAN := FALSE;
---------------------------------------------------------------------------
PROCEDURE-------------------------------------------------------- FP computation ---Initialize () = BEGIN stack := NEW (REF ARRAY OF Info, 100); mbuf := M3Buf.New (); reps := NEW (TypeList, 256); ExpandHash (); END Initialize; PROCEDUREReset () = VAR t: Type.T; BEGIN (* remove the reps and reinstall them as needed in the next compilation *) FOR i := 0 TO n_reps - 1 DO t := reps[i]; t.rep_id := TypeRep.NO_UID; t.scc_id := TypeRep.NO_SCC; reps[i] := NIL; END; (* clear the hash table *) FOR i := FIRST (hash_table^) TO LAST (hash_table^) DO hash_table[i] := TypeRep.NO_UID; END; n_reps := 0; END Reset;
PROCEDUREFromType (t: Type.T): M3FP.T = VAR n: Node; BEGIN <*ASSERT NOT busy *> busy := TRUE; IF (t = NIL) THEN RETURN M3FP.Zero; END; n := Type.Check (t); n := GetRep (n); IF (n.uid = TypeRep.NO_UID) THEN dfs_cnt := DFS_reset; EVAL Visit_SCC (n); END; IF (n # t) THEN t.fp := n.fp; t.uid := n.uid; END; busy := FALSE; RETURN n.fp; END FromType; PROCEDUREVisit_SCC (n: Node): INTEGER = (* Find the strongly connected component containing 'n' and compute the fingerprints of its elements *) VAR here, min, x: INTEGER; ch: Node; BEGIN (* push 'n' on the stack *) here := tos; INC (tos); IF (tos > NUMBER (stack^)) THEN ExpandStack () END; WITH z = stack[here] DO z.node := n; n.scc_id := -here; (* mark 'n' as visited *) INC (dfs_cnt); z.dfs_id := dfs_cnt; min := dfs_cnt; (* get 'n's tag and list of children *) z.info.tag := NIL; z.info.buf := mbuf; n.fprint (z.info); IF (z.info.tag = NIL) THEN z.info.tag := M3Buf.ToText (z.info.buf); END; z.info.buf := NIL; (* visit each of 'n's children *) FOR i := 0 TO z.info.n_nodes-1 DO IF (z.info.n_nodes <= NUMBER (z.info.nodes)) THEN ch := Type.Check (z.info.nodes[i]); ELSE ch := Type.Check (z.info.others[i]); END; ch := GetRep (ch); x := ch.scc_id; IF (x = NO_SCC) THEN (* we've never visited 'ch' *) min := MIN (min, Visit_SCC (ch)); ELSIF (x < NO_SCC) THEN (* 'ch' is active *) min := MIN (min, stack [-x].dfs_id); (* ELSE (x > 0) => we've already computed the full fp of 'ch', therefore it's not part of the strongly connected component containing 'n'. *) END; END; IF (min = z.dfs_id) THEN (* stack[tos-1 .. here] is a new strongly connected component *) Finish_SCC (SUBARRAY (stack^, here, tos-here)); tos := here; END; END; (* WITH z=stack[here] *) RETURN min; END Visit_SCC; TYPE VisitInfo = RECORD dfs : INTEGER; tags : M3Buf.T; fp : M3FP.T; fp_used : BOOLEAN; END; PROCEDUREFinish_SCC (VAR x: ARRAY OF Info) =
Given the strongly connected componentxwhere the fingerprints of all other reachable nodes are computed, compute the fingerprints of each node inx.
VAR min: CARDINAL; zz: VisitInfo; n_missing := 0; n: Node;
BEGIN
IF NUMBER (x) <= 0 THEN RETURN END;
(* check to see if we've already computed the fingerprints for
this component *)
FOR i := FIRST (x) TO LAST (x) DO
IF (x[i].node.uid = TypeRep.NO_UID) THEN INC (n_missing); END;
END;
IF (n_missing > 0) THEN
IF (Host.vs_debug) THEN DumpHeader () END;
IF (NUMBER (x) = 1) AND (x[0].info.n_nodes = 0) THEN
(* a simple leaf node *)
n := x[0].node;
n.fp := FromText (x[0].info.tag);
n.uid := M3FP.ToInt (n.fp);
x[0].dfs_id := -1;
ELSE
(* tag each node with its index in the component *)
FOR i := FIRST (x) TO LAST (x) DO x[i].node.scc_id := -i; END;
(* find the "least" element *)
min := 0;
FOR i := 1 TO LAST (x) DO
IF CompareInfo (x, i, min) < 0 THEN min := i END;
END;
(* reset the DFS tags *)
FOR i := 0 TO LAST (x) DO x[i].dfs_id := DFS_not_visited; END;
(* compute this component's fingerprint *)
zz.dfs := DFS_reset;
zz.tags := mbuf;
zz.fp := M3FP.Zero;
zz.fp_used := FALSE;
Visit (zz, x, min);
IF (zz.fp_used)
THEN zz.fp := FromPair (FromBuf (zz.tags), zz.fp);
ELSE zz.fp := FromBuf (zz.tags);
END;
(* compute the fingerprint of each element of the component *)
FOR i := FIRST (x) TO LAST (x) DO
WITH z = x[i] DO
z.node.fp := M3FP.ExtendByInt (zz.fp, z.dfs_id);
z.node.uid := M3FP.ToInt (z.node.fp);
END;
END;
END;
(* dump the final fingerprints *)
IF (Host.vs_debug) THEN
FOR i := FIRST (x) TO LAST (x) DO
DumpFP (x[i].dfs_id, NIL, x[i].node.fp);
END;
END;
END; (*IF n_missing > 0*)
(* set the scc_id's and reset the stack nodes *)
FOR i := FIRST (x) TO LAST (x) DO
WITH z = x[i] DO
FOR j := 0 TO MIN (z.info.n_nodes, LAST (z.info.nodes)) DO
z.info.nodes[j] := NIL;
END;
z.node.scc_id := next_scc;
z.node := NIL;
z.info.tag := NIL;
z.info.buf := NIL;
z.info.others := NIL;
z.info.n_nodes := 0;
z.dfs_id := DFS_not_visited;
END;
END;
INC (next_scc);
END Finish_SCC;
PROCEDURE Visit (VAR zz: VisitInfo; VAR x: ARRAY OF Info; n: CARDINAL) =
VAR ch: Node;
BEGIN
WITH z = x[n] DO
IF (z.dfs_id # DFS_not_visited) THEN
M3Buf.PutChar (zz.tags, '|');
M3Buf.PutInt (zz.tags, z.dfs_id);
RETURN;
END;
(* this is the first visit to the node 'z' *)
(* mark 'z' and add its tag *)
z.dfs_id := zz.dfs; INC (zz.dfs);
M3Buf.PutChar (zz.tags, '|');
M3Buf.PutText (zz.tags, z.info.tag);
(* visit each of its children *)
FOR i := 0 TO z.info.n_nodes-1 DO
IF (z.info.n_nodes <= NUMBER (z.info.nodes))
THEN ch := z.info.nodes[i];
ELSE ch := z.info.others[i];
END;
ch := GetRep (ch);
IF (ch.scc_id > NO_SCC) THEN
(* child 'i' outside the component *)
M3Buf.PutChar (zz.tags, '|');
M3Buf.PutChar (zz.tags, '*');
zz.fp := FromPair (zz.fp, ch.fp);
zz.fp_used := TRUE;
ELSE
(* child 'i' inside the component *)
Visit (zz, x, -ch.scc_id);
END;
END;
END;
END Visit;
PROCEDURE CompareInfo (READONLY x: ARRAY OF Info; na, nb: CARDINAL): [-1..1] =
Determine ifx[na]is less than or greater thanx[nb]. Note that an order on the nodes is not defined by the language, but an arbitrary total order that is constant for the duration ofFinish_SCCwill do. In fact, the order defined by this procedure changes from one call ofFinish_SCCto the next.
VAR z: INTEGER; ch_a, ch_b: Node;
BEGIN
WITH a = x[na], b = x[nb] DO
(* first, use the # of children *)
IF (a.info.n_nodes < b.info.n_nodes) THEN RETURN -1 END;
IF (a.info.n_nodes > b.info.n_nodes) THEN RETURN +1 END;
(* next, use the tags *)
z := Text.Compare (a.info.tag, b.info.tag);
IF (z < 0) THEN RETURN -1 END;
IF (z > 0) THEN RETURN +1 END;
(* finally, check the children *)
FOR i := 0 TO a.info.n_nodes-1 DO
IF (a.info.n_nodes <= NUMBER (a.info.nodes)) THEN
ch_a := a.info.nodes[i];
ch_b := b.info.nodes[i];
ELSE
ch_a := a.info.others[i];
ch_b := b.info.others[i];
END;
ch_a := GetRep (ch_a);
ch_b := GetRep (ch_b);
z := CompareNode (x, ch_a, ch_b);
IF (z # 0) THEN RETURN z END;
END;
RETURN 0;
END; (* WITH *)
END CompareInfo;
PROCEDURE CompareNode (READONLY x: ARRAY OF Info; a, b: Node): [-1..1] =
VAR xa, xb: INTEGER;
BEGIN
IF (a = b) THEN RETURN 0 END;
IF (a = NIL) THEN RETURN -1 END;
IF (b = NIL) THEN RETURN +1 END;
xa := a.scc_id;
xb := b.scc_id;
IF (xa > NO_SCC) AND (xb > NO_SCC) THEN
(* both nodes have already have fingerprints *)
WITH fp_a = a.fp, fp_b = b.fp DO
FOR i := 0 TO 7 DO
IF fp_a.byte[i] < fp_b.byte[i] THEN RETURN -1 END;
IF fp_a.byte[i] > fp_b.byte[i] THEN RETURN +1 END;
END;
END;
RETURN 0;
END;
IF Type.IsEqual (a, b, NIL) THEN RETURN 0 END;
IF (xa > NO_SCC) THEN RETURN +1 END;
IF (xb > NO_SCC) THEN RETURN -1 END;
RETURN CompareInfo (x, -xa, -xb);
END CompareNode;
PROCEDURE ExpandStack () =
VAR n := NUMBER (stack^);
VAR new := NEW (REF ARRAY OF Info, 2 * n);
BEGIN
SUBARRAY (new^, 0, n) := stack^;
stack := new;
END ExpandStack;
---------------------------------------------------------- FP utilities ---
PROCEDURE----------------------------------------------------------- unique reps ---FromText (txt: TEXT): M3FP.T = VAR fp := M3FP.FromText (txt); BEGIN IF (Host.vs_debug) THEN DumpFP (-1, txt, fp); END; RETURN fp; END FromText; PROCEDUREFromPair (READONLY a, b: M3FP.T): M3FP.T = VAR fp := M3FP.Combine (a, b); BEGIN IF (Host.vs_debug) THEN DumpOne (b); END; RETURN fp; END FromPair; PROCEDUREFromBuf (buf: M3Buf.T): M3FP.T = BEGIN IF (Host.vs_debug) THEN RETURN FromText (M3Buf.ToText (buf)); ELSE RETURN M3Buf.ToFP (buf); (* avoids the TEXT allocation *) END; END FromBuf;
PROCEDURE------------------------------------------------------------- debugging ---GetRep (t: Type.T): Type.T = VAR uid: INTEGER; hash: INTEGER; r: Type.T; BEGIN IF (t = NIL) THEN t := ErrType.T; END; IF (t.rep_id # TypeRep.NO_UID) THEN (* this type has a uid, but it might be from a old compilation... *) IF (t.rep_id < n_reps) THEN r := reps[t.rep_id]; IF (r = t) OR Type.IsEqual (r, t, NIL) THEN RETURN r; END; END; t.rep_id := TypeRep.NO_UID; END; (* search the hash table for an existing type that's equal *) hash := t.info.hash MOD NUMBER (hash_table^); LOOP uid := hash_table[hash]; IF (uid = TypeRep.NO_UID) THEN (* empty bucket *) EXIT END; r := reps[uid]; IF (r.info.hash = t.info.hash) AND Type.IsEqual (r, t, NIL) THEN (* we found a match *) t.rep_id := uid; RETURN r; END; INC (hash); IF (hash > LAST(hash_table^)) THEN hash := 0 END; END; (* a new type! *) uid := n_reps; t.rep_id := uid; (* add a new type to the rep table *) IF (uid > LAST (reps^)) THEN ExpandReps () END; reps [uid] := t; INC (n_reps); (* update the hash table *) hash_table [hash] := uid; IF (n_reps + n_reps > NUMBER (hash_table^)) THEN ExpandHash () END; RETURN t; END GetRep; PROCEDUREExpandReps () = VAR n := NUMBER (reps^); VAR new := NEW (TypeList, 2 * n); BEGIN SUBARRAY (new^, 0, n_reps) := reps^; reps := new; END ExpandReps; PROCEDUREExpandHash () = VAR n, hash: INTEGER; new: IntList; BEGIN IF (hash_table = NIL) THEN n := 512; ELSE n := 2 * NUMBER (hash_table^); END; new := NEW (IntList, n); (* initialize the new table to all empty slots *) FOR i := 0 TO LAST (new^) DO new[i] := TypeRep.NO_UID END; (* re-insert each type in the new table *) FOR i := 0 TO n_reps-1 DO hash := reps[i].info.hash MOD n; WHILE (new[hash] # TypeRep.NO_UID) DO INC (hash); IF (hash >= n) THEN hash := 0 END; END; new[hash] := i; END; hash_table := new; END ExpandHash;
VAR wr: M3Buf.T := NIL; PROCEDUREDumpHeader () = BEGIN Host.env.note_comment ("---------------------------------------"); END DumpHeader; PROCEDUREDumpFP (i: INTEGER; tag: TEXT; READONLY fp: M3FP.T) = <*FATAL Convert.Failed*> VAR len: INTEGER; buf: M3FP.CharBuf; fp_x := M3FP.ToInt (fp); BEGIN IF (wr = NIL) THEN wr := M3Buf.New () END; IF (tag # NIL) THEN Host.env.note_comment (tag); END; IF (i >= 0) THEN len := Convert.FromInt (buf, i); M3Buf.PutSub (wr, SUBARRAY (buf, 0, len)); M3Buf.PutText (wr, ": "); END; M3Buf.PutText (wr, " FP ==> 16_"); M3FP.ToChars (fp, buf); M3Buf.PutSub (wr, buf); M3Buf.PutText (wr, " => 16_"); len := Convert.FromUnsigned (buf, fp_x, 16); M3Buf.PutSub (wr, SUBARRAY (buf, 0, len)); M3Buf.PutText (wr, " = "); len := Convert.FromInt (buf, fp_x); M3Buf.PutSub (wr, SUBARRAY (buf, 0, len)); Host.env.note_comment (M3Buf.ToText (wr)); END DumpFP; PROCEDUREDumpOne (READONLY fp: M3FP.T) = VAR buf: M3FP.CharBuf; BEGIN IF (wr = NIL) THEN wr := M3Buf.New () END; M3Buf.PutText (wr, " Combine ==> 16_"); M3FP.ToChars (fp, buf); M3Buf.PutSub (wr, buf); Host.env.note_comment (M3Buf.ToText (wr)); END DumpOne; BEGIN END TypeFP.