File: TypeFP.m3 Last modified on Thu Jan 26 14:21:55 PST 1995 by kalsow modified on Tue May 25 14:38:54 PDT 1993 by muller
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 componentx
where 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; PROCEDUREVisit (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; PROCEDURECompareInfo (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_SCC
will do. In fact, the order defined by this procedure changes from one call ofFinish_SCC
to 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---------------------------------------------------------- FP utilities ---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; PROCEDUREExpandStack () = VAR n := NUMBER (stack^); VAR new := NEW (REF ARRAY OF Info, 2 * n); BEGIN SUBARRAY (new^, 0, n) := stack^; stack := new; END ExpandStack;
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.