## points-to.pkg
#
# This module performs low-level flow insensitive
# points-to analysis for type-safe languages.
# Compiled by:
# src/lib/compiler/back/low/lib/lowhalf.lib### "Everyone is more or less mad on one point."
###
### -- Rudyard Kipling
# Currently our code clients are:
#
# src/lib/compiler/back/low/main/main/translate-nextcode-to-treecode-g.pkg# src/lib/compiler/back/low/main/nextcode/memory-aliasing-g.pkg# src/lib/compiler/back/low/main/nextcode/nextcode-ramregions.pkgstipulate
package err = lowhalf_error_message; # lowhalf_error_message is from src/lib/compiler/back/low/control/lowhalf-error-message.pkg package lms = list_mergesort; # list_mergesort is from src/lib/src/list-mergesort.pkg package rkj = registerkinds_junk; # registerkinds_junk is from src/lib/compiler/back/low/code/registerkinds-junk.pkgherein
package points_to
: (weak) Points_To # Points_To is from src/lib/compiler/back/low/aliasing/points-to.api {
Edgekind = PROJECTION | DOMAIN | RANGE | RECORD | MARK;
Cell
= LINK Ramregion # Redirection to another Cell.
| SREF (rkj::Codetemp_Info, Ref( Edges )) # Strong, mutable.
| WREF (rkj::Codetemp_Info, Ref( Edges )) # Weak, mutable.
| SCELL (rkj::Codetemp_Info, Ref( Edges )) # Strong, immutable.
| WCELL (rkj::Codetemp_Info, Ref( Edges )) # Weak, immutable.
| TOP { mutable: Bool, id: rkj::Codetemp_Info, name: String }
# A collapsed node
withtype Ramregion = Ref( Cell )
also Edges = List( (Edgekind, Int, Ramregion) );
fun error msg
=
err::error ("points_to", msg);
# PROJECTION > DOMAIN > RANGE > RECORD
#
fun greater_kind (PROJECTION, _) => FALSE;
greater_kind (DOMAIN, PROJECTION) => FALSE;
greater_kind (RANGE, (PROJECTION | DOMAIN)) => FALSE;
greater_kind (RECORD, (PROJECTION | DOMAIN | RANGE)) => FALSE;
greater_kind (MARK, (PROJECTION | DOMAIN | RANGE | RECORD)) => FALSE;
greater_kind _ => TRUE;
end;
fun less (k, i, k', i')
=
k==k' and i > i' or
greater_kind (k, k');
my sort: List( (Edgekind, Int, Ramregion) )
->
List( (Edgekind, Int, Ramregion) )
=
lms::sort_list (\\ ((k, i, _), (k', i', _)) = less (k, i, k', i')); # Yes, the outer parens are required. Unfortunately.
new_mem = REF (\\ _ = error "new_mem") : Ref( Void -> rkj::Codetemp_Info ); # XXX BUGGO FIXME icky thread-hostile global mutable state.
fun reset f
=
new_mem := f;
fun new_sref () = REF (SREF (*new_mem(), REF [])); # "s" is probably "strong".
fun new_wref () = REF (WREF (*new_mem(), REF [])); # "w" is probably "weak".
fun new_scell () = REF (SCELL (*new_mem(), REF [])); # "s" is probably "strong".
fun new_wcell () = REF (WCELL (*new_mem(), REF [])); # "w" is probably "weak".
fun new_top { name, mutable }
=
REF (TOP { mutable, id=> *new_mem(), name } );
fun chase (REF (LINK x)) => chase x; # Should probably be renamed 'chase'.
chase x => x;
end;
fun mut (r as REF (LINK x)) => mut x; # 'mut' must be 'mutate'. Appears to mean "make_mutable".
#
mut (r as REF (SCELL x)) => r := SREF x;
mut (r as REF (WCELL x)) => r := WREF x;
#
mut (r as REF (TOP { mutable=>FALSE, id, name } ))
=>
r := TOP { mutable=>TRUE, id, name };
mut _ => ();
end
also
fun weak (REF (LINK x)) => weak x; # May mean "make weak".
weak (REF (TOP _)) => ();
#
weak (r as REF (SCELL x)) => { r := WCELL x; merge_pis x;};
weak (r as REF (SREF x)) => { r := WREF x; merge_pis x;};
weak _ => ();
end
also
fun merge_pis (_, edges)
=
{ x = new_scell();
fun merge ([], es') => es';
merge((PROJECTION, _, y) ! es, es') => { unify (x, y); merge (es, es');};
merge (e ! es, es') => merge (es, e ! es');
end;
edges := (PROJECTION, 0, x) ! merge (*edges, []);
}
also
fun get_ith (k, i, REF (LINK x)) => get_ith (k, i, x); # Return target of edge (k, i, ...).
get_ith (k, i, r as REF (TOP _)) => r;
get_ith (k, i, REF (SREF (_, edges))) => get_ith' (k, i, edges);
get_ith (k, i, REF (WREF (_, edges))) => get_ith' (k, i, edges);
get_ith (k, i, REF (SCELL(_, edges))) => get_ith' (k, i, edges);
get_ith (k, i, REF (WCELL(_, edges))) => get_ith' (k, i, edges);
end
also
fun get_ith' (k, i, edges) # Search unsorted(?) list 'edges' for entry (k, i, x), return x.
= # If no such entry, create one with x = new_scell().
search *edges
where
fun search ((k', i', x) ! es)
=>
if (k == k' and i == i') chase x;
else search es;
fi;
search []
=>
{ x = new_scell();
edges := (k, i, x) ! *edges;
x;
};
end;
end
also
fun unify
( x: Ramregion,
y: Ramregion
)
=
{ x = chase x;
y = chase y;
fun link_immut (edges, x, y) = { x := LINK y; collapse_all (*edges, y); };
fun link_mut (edges, x, y) = { x := LINK y; mut y; collapse_all (*edges, y); };
fun linky (ex, ey, x, y) = { x := LINK y; ey := unify_list (*ex, *ey); };
fun linkx (ex, ey, x, y) = { y := LINK x; ex := unify_list (*ex, *ey); };
fun link_wref (ex, ey, id, x, y)
=
{ ey = unify_list (*ex, *ey);
n = WREF (id, REF ey);
x := LINK y;
y := n;
};
if (x != y)
#
case (*x, *y)
#
( TOP { mutable => FALSE, ... },
TOP { mutable => FALSE, ... }
)
=>
x := LINK y;
(TOP _, TOP _) => { x := LINK y; mut y;};
(SREF (_, edges), TOP _) => link_mut (edges, x, y);
(WREF (_, edges), TOP _) => link_mut (edges, x, y);
(SCELL(_, edges), TOP _) => link_immut (edges, x, y);
(WCELL(_, edges), TOP _) => link_immut (edges, x, y);
(TOP _, SREF (_, edges)) => link_mut (edges, y, x);
(TOP _, WREF (_, edges)) => link_mut (edges, y, x);
(TOP _, SCELL(_, edges)) => link_immut (edges, y, x);
(TOP _, WCELL(_, edges)) => link_immut (edges, y, x);
(WREF (_, e1), WREF (_, e2)) => linky (e1, e2, x, y);
(SREF (_, e1), WREF (_, e2)) => linky (e1, e2, x, y);
(WCELL(_, e1), WREF (_, e2)) => linky (e1, e2, x, y);
(SCELL(_, e1), WREF (_, e2)) => linky (e1, e2, x, y);
(WREF (_, e1), SREF (_, e2)) => linkx (e1, e2, x, y);
(SREF (_, e1), SREF (_, e2)) => linkx (e1, e2, x, y);
(WCELL(_, e1), SREF (id, e2)) => link_wref (e1, e2, id, x, y);
(SCELL(_, e1), SREF (_, e2)) => linky (e1, e2, x, y);
(WREF (_, e1), WCELL(_, e2)) => linkx (e1, e2, x, y);
(SREF (_, e1), WCELL(id, e2)) => link_wref (e1, e2, id, x, y);
(WCELL(_, e1), WCELL(_, e2)) => linkx (e1, e2, x, y);
(SCELL(_, e1), WCELL(_, e2)) => linky (e1, e2, x, y);
(WREF (_, e1), SCELL(_, e2)) => linkx (e1, e2, x, y);
(SREF (_, e1), SCELL(_, e2)) => linkx (e1, e2, x, y);
(WCELL(_, e1), SCELL(_, e2)) => linkx (e1, e2, x, y);
(SCELL(_, e1), SCELL(_, e2)) => linkx (e1, e2, x, y);
_ => error "unify";
esac;
fi;
}
also
fun collapse_all ([], _)
=>
();
collapse_all((_, _, x) ! xs, y)
=>
{ unify (x, y);
collapse_all (xs, y);
};
end
also
fun unify_list (l1, l2)
=
merge (sort l1, sort l2)
where
fun merge ([], l) => l;
merge (l, []) => l;
merge (a as (c as (k, i, x)) ! u, b as (d as (k', i', y)) ! v)
=>
if (k==k' and i==i')
unify (x, y);
c ! merge (u, v);
else
if (less (k, i, k', i'))
d ! merge (a, v);
else c ! merge (u, b); fi;
fi;
end;
end;
fun ith_projection (x, i) = get_ith (PROJECTION, i, x);
fun ith_domain (x, i) = get_ith (DOMAIN, i, x);
fun ith_range (x, i) = get_ith (RANGE, i, x);
fun ith_subscript (x, i)
=
{ m = get_ith (PROJECTION, i, x);
mut m;
m;
};
fun ith_offset (x, i)
=
{ unify (x, new_top { mutable=>FALSE, name=>""} );
chase x;
}
also
fun unify_all (x,[])
=>
();
unify_all (x, (_, _, y) ! l)
=>
{ unify (x, y);
unify_all (x, l);
};
end;
fun make_header (NULL, es) => es;
make_header (THE h, es) => (PROJECTION,-1, h) ! es;
end;
fun make_allot (header, xs)
=
(*new_mem(), REF (make_header (header, collect (0, xs,[]))))
where
fun collect (_,[], l) => l;
collect (i, x ! xs, l) => collect (i+1, xs, (PROJECTION, i, x) ! l);
end;
end;
fun make_record (header, xs) = REF (SCELL (make_allot (header, xs)));
fun make_ref (header, x) = REF (SREF (make_allot (header, [x])));
fun make_rw_vector (header, xs) = REF (SREF (make_allot (header, xs)));
fun make_ro_vector (header, xs) = REF (SCELL (make_allot (header, xs)));
fun make_fn xs
=
REF (SCELL (*new_mem(), REF (collect (0, xs, []))))
where
fun collect (_, [], l) => l;
collect (i, x ! xs, l) => collect (i+1, xs, (DOMAIN, i, x) ! l);
end;
end;
fun apply (f, xs)
=
loop (0, xs)
where
fun loop (_, [] ) => ();
loop (i, x ! xs) => { unify (ith_domain (f, i), x);
loop (i+1, xs);
};
end;
end;
fun ret (f, xs)
=
loop (0, xs)
where
fun loop (_, []) => ();
loop (i, x ! xs) => { unify (ith_range (f, i), x);
loop (i+1, xs);
};
end;
end;
fun strong_set (a, i, x)
=
unify (ith_subscript (a, i), x);
fun strong_get (a, i)
=
ith_subscript (a, i);
fun weak_set (a, x)
=
{ element = ith_subscript (a, 0);
weak element;
unify (element, x);
};
fun weak_get a
=
{ element = ith_subscript (a, 0);
weak element;
element;
};
fun interfere (x, y)
=
chase x == chase y;
max_levels
=
lowhalf_control::make_int ("max_levels", "max # of level to show in points_to");
my _ =
max_levels := 3; # XXX BUGGO FIXME More icky thread-hostile mutable global state. :-(
fun ramregion_to_string r
=
ramregion_to_string' (*r, *max_levels)
where
fun ramregion_to_string' (LINK x, level) => ramregion_to_string'(*x, level);
#
ramregion_to_string' (SREF (id, edges), level) => "sref" + rkj::register_to_string id + edgelist_to_string (edges, level);
ramregion_to_string' (WREF (id, edges), level) => "wref" + rkj::register_to_string id + edgelist_to_string (edges, level);
ramregion_to_string' (SCELL (id, edges), level) => "s" + rkj::register_to_string id + edgelist_to_string (edges, level);
ramregion_to_string' (WCELL (id, edges), level) => "w" + rkj::register_to_string id + edgelist_to_string (edges, level);
ramregion_to_string' (TOP { name=>"", mutable=>TRUE, id, ... }, _) => "var" + rkj::register_to_string id;
ramregion_to_string' (TOP { name=>"", mutable=>FALSE, id, ... }, _) => "const" + rkj::register_to_string id;
ramregion_to_string' (TOP { name, ... }, _) => name;
end
also
fun edgelist_to_string (edges, -1)
=>
"";
edgelist_to_string (edges, nesting_level) # We return just "..." when "nesting_level" drops to zero.
=>
case (fold_backward cnv "" *edges)
#
"" => "";
t => if (nesting_level == 0) "...";
else "[" + t + "]";
fi;
esac
where
fun add (a, "") => a;
add (a, b ) => a + ", " + b; # add ("foo","bar") -> "foo, bar"
end;
fun cnv ((PROJECTION, i, x), s) => add (int::to_string i + "->" + ramregion_to_string'(*x, nesting_level - 1), s);
cnv (_, s) => s;
end;
end;
end;
end; # fun to_string
};
end;