1. This file implements links between variables, following the "Compiling with continuations, continued" paper by Andrew Kennedy, and "Shrinking lambda expressions in linear time", by Andrew Appel and Trevor Jim.
Occurrences are linked to one another into a doubly-linked list, such that the doubly-linked list represents the set of all occurrences of a variable. A variable is linked to one of its occurrence (and thus to the set of all occurrences of the variable). This allows adding occurrence, removing occurence, and knowing if there is 0,1, or more occurrence to a variable, in O(1) time.
The set of all occurrences of all variables is partitionned into same-binder equivalence classes using a union-find data structure, i.e. all the members of a partition are occurrences of the same variable. The description of the partition is the binding variable itself. This allows near-constant time access to the binding variable, and merging of occurrence sets.
We chose to keep normal occurrences, and recursive occurrences, in two separate equivalence classes. Not merging them:
replace_with
;
module Union_find = Union_find.Safe
module UniqueId = Unique.Make(struct end)
type (α,β) variable =
{ mutable var_desc: α initialized;
mutable occurrences:(α, β) occurrence option;
mutable recursive_occurrences: (α, β) occurrence option;
var_id: UniqueId.t;
mutable occur_nb: int }
and (α,β) occurrence =
{ mutable occur_desc: β initialized;
mutable link_var: ((α, β) variable,(α, β) occurrence) Union_find.link;
mutable next_occurrence:(α, β) occurrence;
mutable previous_occurrence:(α, β) occurrence;
occur_id: int }
and α initialized = Undef ∣ Initialized_to of α
occur_type
distinguish between normal and recursive occurrences.
The following functions allows code factorisation.
type occur_type = Recursive ∣ Non_recursive
let get_occurrences var (ot:occur_type) = match ot with
∣ Recursive → var.occurrences
∣ Non_recursive → var.recursive_occurrences
let set_occurrences var (ot:occur_type) value = match ot with
∣ Recursive → (var.occurrences ← value)
∣ Non_recursive → (var.recursive_occurrences ← value)
module type DESCRIPTION = sig
type variable_description
type occurrence_description
val var_prefix:string
end
module Make(Desc:DESCRIPTION) = struct
type var_desc = Desc.variable_description
type occur_desc = Desc.occurrence_description
type var = (var_desc, occur_desc) variable
type occur = (var_desc, occur_desc) occurrence
occur
is the variable var
for which occur
is an occurrence.
module Var_union_find = Union_find.Make(struct
type description = var
type element = occur
let set f v = f.link_var ← v
let get f = f.link_var
end)
var_counter
provides unique identifiers when displaying
variables.
let make() =
{ var_desc = Undef;
occurrences = None;
recursive_occurrences = None;
var_id = UniqueId.fresh();
occur_nb = 0 }
let description b = match b.var_desc with
∣ Initialized_to(d) → d
∣ Undef → assert false (∗ Trying to access an uninitialized description. ∗)
let set_description b d = match b.var_desc with
∣ Initialized_to(d) → assert false (∗ Description already initialized. ∗)
∣ Undef → b.var_desc ← Initialized_to(d)
fold_on_occurrences
function.
type number_of_occurrences =
∣ No_occurrence
∣ One_occurrence of occur
∣ Several_occurrences
let number_of_occurrences_ ot var =
match get_occurrences var ot with
∣ None → No_occurrence
∣ Some(occ) →
if occ.previous_occurrence ≡ occ
then begin
assert (occ.next_occurrence ≡ occ);
One_occurrence occ
end
else Several_occurrences
let number_of_occurrences = number_of_occurrences_ Non_recursive
let fold_on_occurrences_ ot var init f =
match get_occurrences var ot with
∣ None → init
∣ Some(occ) →
let rec loop value cur =
if cur ≡ occ
then f value cur
else loop (f value cur) cur.next_occurrence
in loop init occ.next_occurrence
let fold_on_occurrences var init f = fold_on_occurrences_ Non_recursive var init f
let fold_on_recursive_occurrences var init f = fold_on_occurrences_ Recursive var init f
let replace_with_ ot old new_ =
match get_occurrences old ot with
(∗ If there were already no occurrences of old
, there is
nothing to do. ∗)
∣ None → ()
∣ Some(occ_old) as some_occ_old →
((match get_occurrences new_ ot with
∣ None →
set_occurrences new_ ot some_occ_old;
let part_old = Var_union_find.find ufds occ_old in
Var_union_find.set_description ufds part_old new_
∣ Some(occ_new) →
occ_old.next_occurrence.previous_occurrence ← occ_new.previous_occurrence;
occ_new.previous_occurrence.next_occurrence ← occ_old.next_occurrence;
occ_old.next_occurrence ← occ_new;
occ_new.previous_occurrence ← occ_old;
let (part_old,part_new) = (Var_union_find.find ufds occ_old,
Var_union_find.find ufds occ_new) in
ignore(Var_union_find.union ufds part_old part_new new_));
old
can be reused if needed.
set_occurrences old ot None)
let replace_with old new_ =
replace_with_ Recursive old new_;
replace_with_ Non_recursive old new_
let replace_all_non_recursive_occurrences_of_with old new_ =
replace_with_ Non_recursive old new_
var
and its
description
.
let to_string bv = Desc.var_prefix ^ (UniqueId.to_string bv.var_id)
module Ord = struct
type t = var
let compare a b = compare a.var_id b.var_id
end
let make (var,ot) =
(∗ Create an initial self-linked occurrence of var. ∗)
let self_linked_occur var =
var.occur_nb ← var.occur_nb + 1;
let rec occur = { occur_desc = Undef;
link_var = Union_find.empty_link;
next_occurrence = occur;
previous_occurrence = occur;
occur_id = var.occur_nb; }
in occur
in
match get_occurrences var ot with
(∗ If this is the first occurrence of var. ∗)
∣ None →
let new_occur = self_linked_occur var in
ignore(Var_union_find.singleton ufds new_occur var);
set_occurrences var ot (Some(new_occur));
new_occur
(∗ Else there are already some occurrences of var. ∗)
∣ Some(existing_occur) →
let new_occur = self_linked_occur var in
(∗ Insert new between existing and existing.next. ∗)
let following_occur = existing_occur.next_occurrence in
let new_occur = { new_occur
with next_occurrence = following_occur;
previous_occurrence = existing_occur } in
existing_occur.next_occurrence ← new_occur;
following_occur.previous_occurrence ← new_occur;
(∗ Merge new to the partition of occurrences of var. ∗)
let new_part = Var_union_find.singleton ufds new_occur var in
let existing_part = (Var_union_find.find ufds existing_occur) in
ignore(Var_union_find.union ufds new_part existing_part var);
new_occur
occur
is an occurrence.
let binding_variable occur =
let part = Var_union_find.find ufds occur in
Var_union_find.description ufds part
occur
from the doubly-linked list of occurrences.
Following Andrew Kennedy, the union-find data structure is not
changed.
let delete occur =
let next = occur.next_occurrence in
let prev = occur.previous_occurrence in
let var = binding_variable occur in
if (occur ≡ next)
(∗ One-variable case. ∗)
then begin
assert (occur ≡ prev);
match (var.occurrences, var.recursive_occurrences) with
∣ (Some(a),_) when a ≡ occur → var.occurrences ← None;
∣ (_,Some(a)) when a ≡ occur → var.recursive_occurrences ← None;
∣ _ → assert false
end
else begin
assert (occur ≢ prev);
prev.next_occurrence ← next;
next.previous_occurrence ← prev;
(match var.occurrences with
∣ Some(a) when a ≡ occur → var.occurrences ← Some(prev)
∣ _ →
(match var.recursive_occurrences with
∣ Some(a) when a ≡ occur → var.recursive_occurrences ← Some(prev)
∣ _ → ()))
Var
, description can be get and set only once.
let description b = match b.occur_desc with
∣ Initialized_to(d) → d
∣ Undef → assert false (∗ Trying to access an uninitialized description. ∗)
let set_description b d = match b.occur_desc with
∣ Initialized_to(d) → assert false (∗ Description already initialized. ∗)
∣ Undef → b.occur_desc ← Initialized_to(d)
let to_string occur =
let bv = binding_variable occur in
(Var.to_string bv) ^ "_" ^ (string_of_int occur.occur_id)
module Ord = struct
type t = occur
let compare a b =
let unique_id o =
let x = binding_variable o in
(x.var_id, o.occur_id) in
compare (unique_id a) (unique_id b)