diff --git a/README.md b/README.md index e2de054..0401f52 100644 --- a/README.md +++ b/README.md @@ -66,6 +66,26 @@ constructors a program makes as it runs. The module comment of relation `intern/2`, the Id and its shape, the templates, the rewrite of a clause, the two rules for a file that opts in, and the known defects. +### Calling a module that hands out layers + +A module that does not opt in may read an Id one layer at a time and hand +out that layer, a plain compound whose arguments are Ids. In a file that +opts in, a plain `slot(Index)` written in a call would be rewritten into an +Id pattern and would not match it. `rewritten/2` names the argument +positions that hold such a layer: there the constructor stays as written +and only its arguments are rewritten. The first argument of +`hash_consing:represented/2` is such a position already. + +```prolog +:- hash_consing:rewritten([slot(_), link(_, _)], + [layer_arguments([stored_layer(_, layer)])]). + +slot_read(Slot, Index) :- + stored_layer(Slot, slot(Index)). % slot(Index) is a plain layer +linked_index(Link, Index) :- + stored_layer(Link, link(slot(Index), _)). % the inner slot/1 is an Id +``` + ## Templates are patterns What is interned is chosen by patterns, not by constructors. A template is @@ -117,6 +137,59 @@ keeps its meaning and loses the first argument index there. A body goal hands such an occurrence over decided: what is bound of it must settle whether a template matches, or the call raises an instantiation error. +## The store + +The store belongs to the process: every thread and every engine interns into +it and reads its Ids, with nothing to install. An Id is never freed nor +reused, and two Ids are `==` exactly when their terms are. The size of the +store is read with `store_property/1`: + +```prolog +?- hash_consing:store_property(bytes(Bytes)). +``` + +with the properties `ids(Count)`, `nodes(Count)` and `bytes(Bytes)`. The +Prolog flag `hash_consing_store_limit` bounds the store, as the stack and +table limits bound theirs: past it, the next insertion raises +`resource_error(hash_consing_store)` and the store keeps what it holds. + +```prolog +?- set_prolog_flag(hash_consing_store_limit, 536870912). +``` + +A process that runs many jobs on one store, each in a thread of its own, +bounds each job by what it adds instead: `store_growth_bounded(Bytes)` lets +the calling thread grow the store by `Bytes` from the call on. Only the +thread's own insertions count, so jobs running in parallel do not charge +each other and a job is not charged with what earlier jobs interned. A +thread created later inherits the bound with a count of its own from zero, +as it inherits `stack_limit` and `table_space`. Interning a term already in +the store adds nothing and costs nothing against the budget. + +```prolog +?- thread_create(( hash_consing:store_growth_bounded(268435456), job ), Thread, []). +``` + +An interned term is a value, not a cell: the store keeps a copy of the term +as it was when interned, and `setarg/3` or `nb_setarg/3` on the original or +on a layer read back changes that copy only. Keep mutable cells (thunks, +memory cells updated in place) out of the store. Never mutate an Id: a +handle that is not one the store gave crashes the process. + +## Incompatible changes in 0.3.0 + +- The store is a fact of the process, no longer two global variables of the + loading thread: a thread or engine interns into it with nothing to + install, and code that read or set `hash_consing_store` or + `hash_consing_spellings` drops those reads. +- In a file that opts in, the template list handed to `internalized/3` or + `declared/1` is kept as written; 0.2.x rewrote it like any other argument. +- In a file that opts in, the first argument of `represented/2` is a plain + layer; 0.2.x rewrote it into an Id pattern, and the call raised. +- New predicates: `store_property/1`, `store_growth_bounded/1`, + `rewritten/2`; new Prolog flags `hash_consing_store_limit`, + `hash_consing_growth_budget`. + ## Incompatible changes in 0.2.0 - A nested template requires its constructor: `apply(apply(*, _), _)` matches diff --git a/pack.pl b/pack.pl index efdfc37..a2e2a63 100644 --- a/pack.pl +++ b/pack.pl @@ -1,5 +1,5 @@ name(hash_consing). -version('0.2.2'). +version('0.3.0'). title('Hash-consed terms by clause rewriting'). keywords([interning, 'hash-consing', trie, term_expansion]). author('Yang, Bo', 'yang-bo@yang-bo.com'). diff --git a/prolog/hash_consing.pl b/prolog/hash_consing.pl index 67cbe1f..c9a16f7 100644 --- a/prolog/hash_consing.pl +++ b/prolog/hash_consing.pl @@ -5,7 +5,10 @@ externalized/2, % +TermWithIds, -External internalized/3, % +Templates, +External, -TermWithIds declared/1, % +Templates - rewritten/1 % +Templates + rewritten/1, % +Templates + rewritten/2, % +Templates, +Options + store_property/1, % ?Property + store_growth_bounded/1 % +Bytes ]). /** hash_consing: hash-consed terms selected by templates, whose Ids record a shape, and a term rewrite that makes a program use them @@ -182,6 +185,14 @@ any other value. `represented(?Layer, ?Representation)` relates one layer, a constructor applied to represented arguments, to its representation. +A LAYER POSITION holds a layer, not a representation: in a file that opts +in, the term written there keeps its own constructor as a plain term and +only its arguments are rewritten. The first argument of `represented/2` is +one; `rewritten/2`'s option `layer_arguments` names more, in the heads and +goals of the file, for a predicate of a module that does not opt in and +hands out or takes the plain layer of a listed constructor (a reader of one +layer). A variable there stays a variable. + `:- hash_consing:rewritten(Templates).` OPTS A FILE IN (user ruling, 2026-09-17: opt-in per file, the constructors passed to the directive, no setting). It declares the templates as `declared/1` does, and every clause @@ -242,7 +253,9 @@ still undecided), call, and then settle every occurrence top down (a lookup when the call bound the Id, an insertion when it made the term ground, an instantiation error when - neither) + neither). An Id occurrence over variables that occur once in + the clause is unread: its Id pattern alone is passed, and + after the call only its handle is checked ground an occurrence that is ground in the source is represented while the file loads, and its Id or its layer is written into the clause @@ -272,16 +285,38 @@ opaque key, whose result does not depend on the order (an assoc key, a sort to remove duplicates), is fine. -THREADS SHARE THE STORE WHEN THEY INSTALL IT. The store and the spellings -of the shapes are tries in two global variables of the thread that loaded -this module, `hash_consing_store` and `hash_consing_spellings`, and a -thread made later starts without them; a thread that sets both to the -loading thread's tries (read there with `nb_getval/2`, set with -`nb_setval/2`) declares, interns and looks up alongside the others, with -the answers one thread would give. A lookup that finds its key takes no -lock. A declaration, an insertion into the store and a new spelling each -take a mutex (`hash_consing_templates`, `hash_consing_store`, -`hash_consing_spellings`) and look again under it before they write. +THE STORE BELONGS TO THE PROCESS. The store and the spellings of the shapes +are two tries made when this module is first loaded and kept in the fact +`process_stores/2`, so every thread and every engine interns into the same +store and reads the same Ids, with nothing to install. Reloading the module +keeps them. A lookup that finds its key with its handle written back takes no +lock; every write to the store, a value still `pending` settled included, is +made under a mutex. The Prolog flag `hash_consing_store_limit`, `infinite` +by default, bounds the bytes of the store: an insertion that would grow it +past the limit raises `resource_error(hash_consing_store)`, the way the +stack and table limits do, and the store stays as it was. +`store_growth_bounded/1` bounds instead what one thread adds to the store +from the call on, the way the stack and table limits bound one thread, so a +thread that shares the store with others, or finds it already full of what +earlier work interned, is charged with its own insertions only. A +declaration, an insertion into the store and a new spelling each take a mutex +(`hash_consing_templates`, `hash_consing_store`, `hash_consing_spellings`) +and look again under it before they write. `store_property/1` reads the size +of the store. + +AN ID IS NEVER FREED NOR REUSED. The store only grows: an Id stays valid, and +stands for the same term, until the process ends. Two Ids are `==` exactly +when the terms they stand for are `==`, so an Id is a key of its term. + +AN INTERNED TERM IS A VALUE, NOT A CELL. `intern/2` stores a copy of the +term as it is at the call: a later `setarg/3` or `nb_setarg/3` on the term +that was interned, or on a layer read back from an Id, changes that copy +only, never the store, and interning the old value again answers the same +Id. So a mutable cell (a thunk, a memory cell updated in place) must stay +outside the store; interning it freezes its value at that moment. An Id +itself must never be mutated: an Id whose handle is set to another Id's +handle is that other Id, and one set to any other integer crashes the +process (the FIXME below on `trie_term/2`). THIS MODULE REFLECTS ON SOURCE CLAUSES with `=..` while a file loads, a mechanical boundary; nothing here chooses behaviour at run time by @@ -295,8 +330,7 @@ FIXME: an Id written into a clause while the file loads is a handle of this process. A file must be loaded from source, never -`qcompile`d nor saved in a state, and a thread reads such an Id only after it -installs the loading thread's store (THREADS SHARE THE STORE, above). +`qcompile`d nor saved in a state. FIXME: a file that uses a constructor another file interns, without listing it, passes its instances uninterned; the rewritten @@ -311,14 +345,34 @@ %! stores_created % -% The store and the spellings of the shapes, two tries in global variables -% of the loading thread. +% The store and the spellings of the shapes, two tries of the process, +% made unless an earlier load of this module made them. + +:- dynamic process_stores/2. stores_created :- - trie_new(Store), - nb_setval(hash_consing_store, Store), - trie_new(Spellings), - nb_setval(hash_consing_spellings, Spellings). + ( process_stores(_, _) + -> true + ; trie_new(Store), + trie_new(Spellings), + assertz(process_stores(Store, Spellings)) + ). + +%! store_property(?Property) is nondet. +% +% A property of the store: `ids(Count)`, the number of terms interned; +% `nodes(Count)`, the number of nodes of its trie; `bytes(Bytes)`, the +% memory the trie takes. The spellings of the shapes are not counted. + +store_property(ids(Count)) :- + process_stores(Store, _), + trie_property(Store, value_count(Count)). +store_property(nodes(Count)) :- + process_stores(Store, _), + trie_property(Store, node_count(Count)). +store_property(bytes(Bytes)) :- + process_stores(Store, _), + trie_property(Store, size(Bytes)). % ---- the relation ---- @@ -343,6 +397,12 @@ % When a template of Term's constructor matches it, insert Term unless it is % stored, and answer its Id; fail, inserting nothing, when none does. +upserted(Term, Id) :- + process_stores(Trie, _), + trie_lookup(Trie, Term, Handle), + Handle \== pending, + !, + stored_id(Term, Handle, Id). upserted(Term, Id) :- ( ground(Term) -> true @@ -350,26 +410,178 @@ ), functor(Term, Name, Arity), templates_known(Name, Arity, hash_consing:intern/2, Templates, Kind), - first_template_recorded(Templates, Term, Structure), - nb_getval(hash_consing_store, Trie), - ( trie_lookup(Trie, Term, Found) - -> settled_handle(Trie, Term, Found, Handle) + ( Kind == root_only + -> true + ; first_template_recorded(Templates, Term, Structure) + ), + process_stores(Trie, _), + ( trie_lookup(Trie, Term, Found), + Found \== pending + -> Handle = Found ; with_mutex(hash_consing_store, handle_inserted(Trie, Term, Handle)) ), id_built(Name, Arity, Kind, Structure, Handle, Id). +% stored_id(+Term, +Handle, ?Id): the Id of a term found in the store +% with its handle written back. A stored term is ground and was declared, +% and the first template that matched it when it was inserted still does, +% so only the shape is computed again. + +stored_id(Term, Handle, Id) :- + functor(Term, Name, Arity), + constructor_templates(Name, Arity, Templates, Kind), + ( Kind == root_only + -> known_id_name(Name, Arity, IdName), + compound_name_arguments(Id, IdName, [Handle]) + ; first_template_recorded(Templates, Term, Structure), + id_built(Name, Arity, Kind, Structure, Handle, Id) + ). + % handle_inserted(+Trie, +Term, -Handle): Term looked up again and, when it % is still absent, inserted, under the mutex `hash_consing_store`. Two % threads that share the store and both miss Term would otherwise both % insert it, and the second trie_insert/4 raises % `permission_error(modify, trie_key, Term)` (measured 2026-09-30: eight % threads interning the same 20000 terms raised in 5 of 5 runs). A lookup -% that finds Term takes no mutex. +% that finds Term with its handle written back takes no mutex; a value +% still `pending`, written by an insertion in progress in another thread or +% left by an interrupted one, is settled here, under the mutex, so that only +% the thread holding it writes to the store. handle_inserted(Trie, Term, Handle) :- ( trie_lookup(Trie, Term, Found) -> settled_handle(Trie, Term, Found, Handle) - ; sig_atomic(inserted(Trie, Term, Handle)) + ; store_within_limit(Trie), + thread_growth_within_budget(Trie), + trie_property(Trie, node_count(NodesBefore)), + sig_atomic(inserted(Trie, Term, Handle)), + thread_growth_counted(Trie, NodesBefore) + ). + +%! store_within_limit(+Trie) +% +% Raises `resource_error(hash_consing_store)` when the Prolog flag +% `hash_consing_store_limit` is a number of bytes and the store takes more. +% Measuring the bytes walks the whole trie (20 ms at 200,000 terms, +% measured 2026-10-01), its node count does not, so the bytes are +% estimated from the node count and the bytes per node of the last +% measurement, and measured again only when the estimate passes the limit +% or the nodes have doubled since; only a measurement raises. + +:- create_prolog_flag(hash_consing_store_limit, infinite, [type(term), keep(true)]). + +store_within_limit(Trie) :- + current_prolog_flag(hash_consing_store_limit, Limit), + ( Limit == infinite + -> true + ; must_be(positive_integer, Limit), + trie_property(Trie, node_count(Nodes)), + bytes_per_node(Trie, Nodes, MeasuredNodes, MeasuredBytes), + ( Nodes * MeasuredBytes =< Limit * MeasuredNodes + -> true + ; trie_property(Trie, size(Bytes)), + flag(hash_consing_measured_nodes, _, Nodes), + flag(hash_consing_measured_bytes, _, Bytes), + ( Bytes > Limit + -> format(atom(Measured), 'the store takes ~D bytes, the limit is ~D', [Bytes, Limit]), + throw(error(resource_error(hash_consing_store), + context(hash_consing:intern/2, Measured))) + ; true + ) + ) + ). + +% bytes_per_node(+Trie, +Nodes, -MeasuredNodes, -MeasuredBytes): the nodes +% and bytes of the last measurement of the store, measured again when +% there is none or the nodes have doubled since; their ratio estimates the +% bytes of a node. + +bytes_per_node(Trie, Nodes, MeasuredNodes, MeasuredBytes) :- + flag(hash_consing_measured_nodes, KnownNodes, KnownNodes), + flag(hash_consing_measured_bytes, KnownBytes, KnownBytes), + ( KnownNodes > 0, + Nodes < 2 * KnownNodes + -> MeasuredNodes = KnownNodes, + MeasuredBytes = KnownBytes + ; trie_property(Trie, size(Bytes)), + MeasuredNodes is max(Nodes, 1), + MeasuredBytes = Bytes, + flag(hash_consing_measured_nodes, _, MeasuredNodes), + flag(hash_consing_measured_bytes, _, MeasuredBytes) + ). + +%! store_growth_bounded(+Bytes) +% +% From now on, this thread may grow the store by Bytes at most; `infinite` +% lifts the bound. Once the nodes this thread inserted since the call take +% more than Bytes, its next insertion raises +% `error(resource_error(hash_consing_store), context(hash_consing:intern/2, +% Message))`, Message stating the bytes added and the budget, the error +% the flag `hash_consing_store_limit` raises. A term already in the store +% costs nothing: interning it again adds no node, is not counted, and is +% answered even past the budget. Only this thread's own insertions +% count, measured as the nodes each one adds under the store's mutex, so +% threads that share the store do not charge each other, and what the +% store held before the call does not count. A thread created later inherits the bound with a count +% of its own from zero, as it inherits `stack_limit` and `table_space`. +% Bytes are estimated from the nodes as for the flag +% `hash_consing_store_limit`. The bound lives in the Prolog flag +% `hash_consing_growth_budget`. + +:- create_prolog_flag(hash_consing_growth_budget, infinite, [type(term), keep(true)]). + +store_growth_bounded(Bytes) :- + ( Bytes == infinite + -> true + ; must_be(positive_integer, Bytes) + ), + set_prolog_flag(hash_consing_growth_budget, Bytes), + nb_setval(hash_consing_growth_added, 0). + +% thread_growth_within_budget(+Trie): the nodes this thread inserted since +% its budget was set take no more than the budget. + +thread_growth_within_budget(Trie) :- + current_prolog_flag(hash_consing_growth_budget, Bytes), + ( Bytes == infinite + -> true + ; thread_growth_added(Added), + trie_property(Trie, node_count(Nodes)), + bytes_per_node(Trie, Nodes, MeasuredNodes, MeasuredBytes), + ( Added * MeasuredBytes =< Bytes * MeasuredNodes + -> true + ; Spent is Added * MeasuredBytes // MeasuredNodes, + format(atom(Measured), + 'this thread grew the store by about ~D bytes, its budget is ~D', + [Spent, Bytes]), + throw(error(resource_error(hash_consing_store), + context(hash_consing:intern/2, Measured))) + ) + ). + +% thread_growth_added(-Added): the nodes this thread inserted since its +% budget was set; zero in a thread that inherited the budget and has not +% inserted yet. + +thread_growth_added(Added) :- + ( nb_current(hash_consing_growth_added, Added) + -> true + ; Added = 0 + ). + +% thread_growth_counted(+Trie, +NodesBefore): the nodes the insertion just +% made, the store's nodes now less NodesBefore, added to this thread's +% count when it has a budget. Called under the store's mutex, right after +% the insertion, so no other thread's nodes are counted. + +thread_growth_counted(Trie, NodesBefore) :- + current_prolog_flag(hash_consing_growth_budget, Bytes), + ( Bytes == infinite + -> true + ; thread_growth_added(AddedBefore), + trie_property(Trie, node_count(Nodes)), + Added is AddedBefore + Nodes - NodesBefore, + nb_setval(hash_consing_growth_added, Added) ). % inserted(+Trie, +Term, -Handle): the insertion and the write-back of the @@ -442,6 +654,13 @@ Class == must_not_intern ). +representation_made(_, _, _, _, Layer, Representation) :- + ground(Layer), + !, + ( upserted(Layer, Id) + -> Representation = Id + ; Representation = Layer + ). representation_made(Templates, Kind, Name, Arity, Layer, Representation) :- value_classified(Templates, Layer, Class, Structure), ( Class == must_intern @@ -471,10 +690,15 @@ %! is_id(+Value) % % Value is an Id: an Id functor this process made, applied to a bound -% handle. +% handle. The handle is the last argument of both Id arities, so the test +% reads it directly instead of through id_parts/4: lambda_jit's +% term_weight.pl calls it once per node it weighs. is_id(Value) :- - id_parts(Value, _, _, Handle), + compound(Value), + compound_name_arity(Value, IdName, Arity), + id_constructor(IdName, _, _), + arg(Arity, Value, Handle), nonvar(Handle). %! id_parts(+Value, -IdName, -Shape, -Handle) @@ -939,7 +1163,7 @@ % it is built once. structure_spelled(Structure, Atom) :- - nb_getval(hash_consing_spellings, Spellings), + process_stores(_, Spellings), ( trie_lookup(Spellings, Structure, Known) -> Atom = Known ; with_mutex(hash_consing_spellings, spelling_inserted(Spellings, Structure, Atom)) @@ -1056,7 +1280,10 @@ instance_internalized(Name/Arity, Constructors, Layer, Internal) :- ( memberchk(Name/Arity, Constructors) -> ( ground(Layer) - -> represented(Layer, Internal) + -> ( upserted(Layer, Id) + -> Internal = Id + ; Internal = Layer + ) ; constructor_templates(Name, Arity, Templates, _), value_classified(Templates, Layer, Class, _), ( Class == must_not_intern @@ -1072,18 +1299,96 @@ %! rewritten(+Templates) % % The file being loaded opts in for the constructors whose templates are in -% the list; several calls add up. +% the list; several calls add up. The same as `rewritten(Templates, [])`. + +%! rewritten(+Templates, +Options) +% +% rewritten/1 with Options, of which there is one: +% +% - layer_arguments(Skeletons) +% Each skeleton is a head or goal, `Name(A1, ..., An)`, with the atom +% `layer` at the argument positions that hold a LAYER and `_` +% elsewhere. In every head and body goal of the file with that name +% and arity, the term at a layer position keeps its own constructor as +% written, a plain term, and only its arguments are rewritten, as +% hash_consing:represented/2 reads its first argument. This is how a +% file that opts in calls a predicate of a file that does not, one +% that hands out or takes the plain layer of a listed constructor. :- dynamic registered_constructor/3. % registered_constructor(SourceFile, Name, Arity) +:- dynamic registered_layer_positions/4. % registered_layer_positions(SourceFile, Name, Arity, Positions) rewritten(Templates) :- + rewritten_with_options(Templates, [], hash_consing:rewritten/1). + +rewritten(Templates, Options) :- + rewritten_with_options(Templates, Options, hash_consing:rewritten/2). + +rewritten_with_options(Templates, Options, Context) :- must_be(list, Templates), + must_be(list, Options), + options_checked(Options, Context, Layered), ( prolog_load_context(source, File) -> true - ; throw(error(context_error(nodirective, hash_consing:rewritten/1), _)) + ; throw(error(context_error(nodirective, Context), _)) ), - templates_declared(Templates, hash_consing:rewritten/1, Constructors), - constructors_registered(Constructors, File). + templates_declared(Templates, Context, Constructors), + constructors_registered(Constructors, File), + layered_registered(Layered, File, Context). + +options_checked([], _, []). +options_checked([Option | Options], Context, Layered) :- + ( Option = layer_arguments(Skeletons), + is_list(Skeletons) + -> skeletons_read(Skeletons, Context, Layered, Rest), + options_checked(Options, Context, Rest) + ; throw(error(domain_error(rewritten_option, Option), context(Context, _))) + ). + +% skeletons_read(+Skeletons, +Context, -Layered, ?Rest): each skeleton +% read as `layered(Name, Arity, Positions)`, its layer positions, in front +% of Rest. + +skeletons_read([], _, Rest, Rest). +skeletons_read([Skeleton | Skeletons], Context, [layered(Name, Arity, Positions) | Layered], Rest) :- + ( compound(Skeleton), + compound_name_arguments(Skeleton, Name, Arguments), + layer_markers(Arguments, 1, Positions), + Positions \== [] + -> length(Arguments, Arity) + ; throw(error(domain_error(layer_skeleton, Skeleton), context(Context, _))) + ), + skeletons_read(Skeletons, Context, Layered, Rest). + +% layered_registered(+Layered, +File, +Context): the layer positions +% recorded for File; a second skeleton of the same name and arity in one +% file must give the same positions. + +layered_registered([], _, _). +layered_registered([layered(Name, Arity, Positions) | Layered], File, Context) :- + ( registered_layer_positions(File, Name, Arity, Known) + -> ( Known == Positions + -> true + ; throw(error(permission_error(reconfigure, layer_arguments, Name/Arity), + context(Context, _))) + ) + ; assertz(registered_layer_positions(File, Name, Arity, Positions)) + ), + layered_registered(Layered, File, Context). + +% layer_markers(+Arguments, +Position, -Positions): the positions, from +% Position on, of the arguments that are the atom `layer`; any other +% argument must be a variable. + +layer_markers([], _, []). +layer_markers([Argument | Arguments], Position, Positions) :- + Next is Position + 1, + ( Argument == layer + -> Positions = [Position | Rest] + ; var(Argument) + -> Positions = Rest + ), + layer_markers(Arguments, Next, Rest). constructors_registered([], _). constructors_registered([Name/Arity | Constructors], File) :- @@ -1109,6 +1414,7 @@ prolog_load_context(source, File), prolog_load_context(file, File), retractall(registered_constructor(File, _, _)), + retractall(registered_layer_positions(File, _, _, _)), fail. source_rewritten((:- _), _) :- !, @@ -1144,14 +1450,17 @@ plain_rule_rewritten(Head0, Body0, File, Head, Body). plain_rule_rewritten(Head0, Body0, File, Head, Body) :- - arguments_of_abstracted(Head0, File, Head, Occurrences), - body_rewritten(Body0, File, RewrittenBody), - head_scheduled(Occurrences, RewrittenBody, Body). + file_layer_positions(Head0, File, Positions), + arguments_of_abstracted(Head0, Positions, File, Head, Occurrences), + term_singletons(Head0-Body0, Singletons), + body_rewritten(Body0, rewriting(File, Singletons), RewrittenBody), + head_scheduled(Occurrences, Head-RewrittenBody, RewrittenBody, Body). -%! arguments_of_abstracted(+Callable0, +File, -Callable, -Occurrences) +%! arguments_of_abstracted(+Callable0, +LayerPositions, +File, -Callable, -Occurrences) % % The arguments of a head or a goal abstracted (its own functor is a -% predicate and is left alone), the ground occurrences represented now, and +% predicate and is left alone; an argument at one of LayerPositions keeps +% its own constructor), the ground occurrences represented now, and % the others listed bottom up as % `occurrence(Class, Layer, Representation, Handle)`: Class `id` for an % occurrence that must be interned, its Representation an Id pattern and @@ -1160,15 +1469,52 @@ % written where it stood. An occurrence that must not be interned is its % layer, written in place, and is not listed. -arguments_of_abstracted(Callable0, File, Callable, Occurrences) :- +arguments_of_abstracted(Callable0, LayerPositions, File, Callable, Occurrences) :- compound(Callable0), !, compound_name_arguments(Callable0, Name, Arguments0), - arguments_abstracted(Arguments0, File, Arguments, [], Reversed), + positioned_arguments_abstracted(Arguments0, 1, LayerPositions, File, Arguments, [], Reversed), compound_name_arguments(Callable, Name, Arguments), reverse(Reversed, BottomUp), occurrences_baked(BottomUp, Occurrences). -arguments_of_abstracted(Callable, _, Callable, []). +arguments_of_abstracted(Callable, _, _, Callable, []). + +% file_layer_positions(+Callable, +File, -Positions): the layer positions +% File registered for Callable's name and arity (rewritten/2), none when +% it registered none. + +file_layer_positions(Callable, File, Positions) :- + ( compound(Callable), + compound_name_arity(Callable, Name, Arity), + registered_layer_positions(File, Name, Arity, Registered) + -> Positions = Registered + ; Positions = [] + ). + +% positioned_arguments_abstracted(+Arguments0, +Position, +LayerPositions, +% +File, -Arguments, +Reversed0, -Reversed): arguments_abstracted/5, the +% argument at a layer position kept as a plain layer: its own +% constructor as written, its arguments abstracted. + +positioned_arguments_abstracted([], _, _, _, [], Reversed, Reversed). +positioned_arguments_abstracted([Argument0 | Arguments0], Position, LayerPositions, File, + [Argument | Arguments], Reversed0, Reversed) :- + ( memberchk(Position, LayerPositions) + -> layer_abstracted(Argument0, File, Argument, Reversed0, Reversed1) + ; abstracted(Argument0, File, Argument, Reversed0, Reversed1) + ), + Next is Position + 1, + positioned_arguments_abstracted(Arguments0, Next, LayerPositions, File, + Arguments, Reversed1, Reversed). + +layer_abstracted(Layer0, File, Layer, Reversed0, Reversed) :- + ( compound(Layer0) + -> compound_name_arguments(Layer0, Name, Arguments0), + arguments_abstracted(Arguments0, File, Arguments, Reversed0, Reversed), + compound_name_arguments(Layer, Name, Arguments) + ; Layer = Layer0, + Reversed = Reversed0 + ). arguments_abstracted([], _, [], Reversed, Reversed). arguments_abstracted([Argument0 | Arguments0], File, [Argument | Arguments], Reversed0, Reversed) :- @@ -1242,17 +1588,20 @@ occurrence_represented_now(undetermined(_), Layer, Variable) :- represented(Layer, Variable). -%! head_scheduled(+BottomUp, +Body0, -Body) +%! head_scheduled(+BottomUp, +Clause, +Body0, -Body) % -% The head row of THE REWRITE OF A CLAUSE (above). +% The head row of THE REWRITE OF A CLAUSE (above). Clause is the +% rewritten head paired with Body0, read only to find the occurrences whose +% layer nothing reads. -head_scheduled([], Body, Body) :- +head_scheduled([], _, Body, Body) :- !. -head_scheduled(BottomUp, Body0, (Condition -> Fast ; General)) :- +head_scheduled(BottomUp, Clause, Body0, (Condition -> Fast ; General)) :- reverse(BottomUp, TopDown), top_level_occurrences(BottomUp, BottomUp, TopLevel), occurrences_given(TopLevel, Condition), - occurrences_goal(TopDown, related, Lookups), + occurrences_read(TopDown, Clause-BottomUp, Read), + occurrences_goal(Read, related, Lookups), occurrences_goal(TopDown, related_if_given, Settled), occurrences_goal(BottomUp, represented_if_ground, Inserted), occurrences_goal(BottomUp, settled_unless_given, Finished), @@ -1281,6 +1630,56 @@ kept_conjoined([Goal | Goals], (Goal, Conjunction)) :- kept_conjoined(Goals, Conjunction). +% occurrences_read(+Occurrences, +Clause, -Read): the occurrences whose +% layer the clause reads. A given Id's layer is looked up only to bind the +% layer's arguments; an Id occurrence whose layer is its constructor over +% variables that occur nowhere else in Clause (the head, the body and the +% layers of the listed occurrences) binds nothing anyone reads, and is left +% out of the fast path. Its Id pattern in the head already selects the +% constructor and the shape. Every other occurrence is kept. + +occurrences_read(Occurrences, Clause, Read) :- + variables_occurring_more_than_once(Clause, Shared), + occurrences_kept_when_read(Occurrences, Shared, Read). + +occurrences_kept_when_read([], _, []). +occurrences_kept_when_read([Occurrence | Occurrences], Shared, Read) :- + ( Occurrence = occurrence(id, Layer, _, _), + layer_arguments(Layer, Arguments), + unread_arguments(Arguments, Shared) + -> Read = Rest + ; Read = [Occurrence | Rest] + ), + occurrences_kept_when_read(Occurrences, Shared, Rest). + +layer_arguments(Layer, Arguments) :- + ( atom(Layer) + -> Arguments = [] + ; compound_name_arguments(Layer, _, Arguments) + ). + +unread_arguments([], _). +unread_arguments([Argument | Arguments], Shared) :- + var(Argument), + \+ variable_member(Argument, Shared), + unread_arguments(Arguments, Shared). + +% variables_occurring_more_than_once(+Term, -Shared): the variables of Term +% that occur in it more than once. + +variables_occurring_more_than_once(Term, Shared) :- + term_singletons(Term, Singletons), + term_variables(Term, Variables), + variables_not_in(Variables, Singletons, Shared). + +variables_not_in([], _, []). +variables_not_in([Variable | Variables], Excluded, Kept) :- + ( variable_member(Variable, Excluded) + -> Kept = Rest + ; Kept = [Variable | Rest] + ), + variables_not_in(Variables, Excluded, Rest). + % An occurrence is at the top when its handle is in the layer of no other % listed occurrence; the layer of an occurrence that must not be interned % is written in place and does not hide what it holds. @@ -1375,7 +1774,10 @@ occurrence_goal(represented_before_call, occurrence(undetermined(_), Layer, Variable, _), hash_consing:represented(Layer, Variable)). -%! body_rewritten(+Body0, +File, -Body) +%! body_rewritten(+Body0, +Context, -Body) +% +% Context is `rewriting(File, Singletons)`, Singletons the variables that +% occur once in the source clause. % % The control constructs rewritten inside, every other goal by % `goal_rewritten/3`. @@ -1383,54 +1785,134 @@ body_rewritten(Goal, _, Goal) :- var(Goal), !. -body_rewritten((Left0, Right0), File, (Left, Right)) :- +body_rewritten((Left0, Right0), Context, (Left, Right)) :- !, - body_rewritten(Left0, File, Left), - body_rewritten(Right0, File, Right). -body_rewritten((Left0 ; Right0), File, (Left ; Right)) :- + body_rewritten(Left0, Context, Left), + body_rewritten(Right0, Context, Right). +body_rewritten((Left0 ; Right0), Context, (Left ; Right)) :- !, - body_rewritten(Left0, File, Left), - body_rewritten(Right0, File, Right). -body_rewritten((Condition0 -> Then0), File, (Condition -> Then)) :- + body_rewritten(Left0, Context, Left), + body_rewritten(Right0, Context, Right). +body_rewritten((Condition0 -> Then0), Context, (Condition -> Then)) :- !, - body_rewritten(Condition0, File, Condition), - body_rewritten(Then0, File, Then). -body_rewritten((Condition0 *-> Then0), File, (Condition *-> Then)) :- + body_rewritten(Condition0, Context, Condition), + body_rewritten(Then0, Context, Then). +body_rewritten((Condition0 *-> Then0), Context, (Condition *-> Then)) :- !, - body_rewritten(Condition0, File, Condition), - body_rewritten(Then0, File, Then). -body_rewritten(\+ Goal0, File, \+ Goal) :- + body_rewritten(Condition0, Context, Condition), + body_rewritten(Then0, Context, Then). +body_rewritten(\+ Goal0, Context, \+ Goal) :- !, - body_rewritten(Goal0, File, Goal). -body_rewritten(call(Goal0), File, call(Goal)) :- + body_rewritten(Goal0, Context, Goal). +body_rewritten(call(Goal0), Context, call(Goal)) :- !, - body_rewritten(Goal0, File, Goal). -body_rewritten(forall(Condition0, Action0), File, forall(Condition, Action)) :- + body_rewritten(Goal0, Context, Goal). +body_rewritten(forall(Condition0, Action0), Context, forall(Condition, Action)) :- !, - body_rewritten(Condition0, File, Condition), - body_rewritten(Action0, File, Action). -body_rewritten(findall(Template, Goal0, Result), File, findall(Template, Goal, Result)) :- + body_rewritten(Condition0, Context, Condition), + body_rewritten(Action0, Context, Action). +body_rewritten(findall(Template, Goal0, Result), Context, findall(Template, Goal, Result)) :- !, + context_file(Context, File), listed_absent(Template-Result, File, findall_template_or_result), - body_rewritten(Goal0, File, Goal). -body_rewritten(catch(Goal0, Catcher, Recovery0), File, catch(Goal, Catcher, Recovery)) :- + body_rewritten(Goal0, Context, Goal). +body_rewritten(catch(Goal0, Catcher, Recovery0), Context, catch(Goal, Catcher, Recovery)) :- !, + context_file(Context, File), listed_absent(Catcher, File, catch_catcher), - body_rewritten(Goal0, File, Goal), - body_rewritten(Recovery0, File, Recovery). -body_rewritten(Qualifier:Goal0, File, Qualifier:Goal) :- + body_rewritten(Goal0, Context, Goal), + body_rewritten(Recovery0, Context, Recovery). +body_rewritten(hash_consing:Goal0, Context, hash_consing:Goal) :- + templates_first(Goal0), + !, + templates_kept(Goal0, Context, Goal). +body_rewritten(hash_consing:Goal0, Context, hash_consing:Goal) :- + layer_first(Goal0), + !, + goal_rewritten(Goal0, [1], Context, Goal). +body_rewritten(Qualifier:Goal0, Context, Qualifier:Goal) :- + !, + body_rewritten(Goal0, Context, Goal). +body_rewritten(Goal0, Context, Goal) :- + templates_first(Goal0), + prolog_load_context(module, Module), + predicate_property(Module:Goal0, imported_from(hash_consing)), !, - body_rewritten(Goal0, File, Goal). -body_rewritten(Goal0, File, Goal) :- - goal_rewritten(Goal0, File, Goal). + templates_kept(Goal0, Context, Goal). +body_rewritten(Goal0, Context, Goal) :- + layer_first(Goal0), + prolog_load_context(module, Module), + predicate_property(Module:Goal0, imported_from(hash_consing)), + !, + goal_rewritten(Goal0, [1], Context, Goal). +body_rewritten(Goal0, Context, Goal) :- + context_file(Context, File), + file_layer_positions(Goal0, File, Positions), + goal_rewritten(Goal0, Positions, Context, Goal). + +% templates_first(+Goal): Goal is a predicate of this library whose first +% argument is a list of templates. The templates are data the library +% reads, not terms to intern, so a call of it in an opted-in file keeps +% them as written (templates_kept/3), and only its other arguments are +% rewritten. + +templates_first(internalized(_, _, _)). +templates_first(declared(_)). + +templates_kept(Goal0, Context, Goal) :- + compound_name_arguments(Goal0, Name, [Templates | Arguments]), + compound_name_arguments(StandIn, Name, [Placeholder | Arguments]), + goal_rewritten(StandIn, [], Context, Goal), + Placeholder = Templates. + +% layer_first(+Goal): Goal is a predicate of this library whose first +% argument is a layer, kept as a plain layer in an opted-in file. + +layer_first(represented(_, _)). -%! goal_rewritten(+Goal0, +File, -Goal) +context_file(rewriting(File, _), File). + +%! goal_rewritten(+Goal0, +LayerPositions, +Context, -Goal) % -% The body goal row of THE REWRITE OF A CLAUSE (above). +% The body goal row of THE REWRITE OF A CLAUSE (above), the arguments at +% LayerPositions kept as plain layers. An Id occurrence whose layer is its +% constructor over variables that occur once in the source clause is +% UNREAD: those variables are unbound at the call and nobody reads them +% after it, so its Id pattern alone, which selects the constructor and the +% shape, is all the goal needs. It is left out of the schedule; after the +% call only its handle is checked, and an unbound handle is handed to +% intern/2, which raises as it would have. + +goal_rewritten(Goal0, LayerPositions, rewriting(File, Singletons), Goal) :- + arguments_of_abstracted(Goal0, LayerPositions, File, Called, BottomUp), + occurrences_partitioned(BottomUp, Singletons, Read, Unread), + goal_scheduled(Read, Called, Scheduled), + unread_checks(Unread, Checks), + conjoined([Scheduled | Checks], Goal). + +occurrences_partitioned([], _, [], []). +occurrences_partitioned([Occurrence | Occurrences], Singletons, Read, Unread) :- + ( Occurrence = occurrence(id, Layer, _, _), + layer_arguments(Layer, Arguments), + Arguments \== [], + singleton_arguments(Arguments, Singletons) + -> Unread = [Occurrence | UnreadRest], + Read = ReadRest + ; Read = [Occurrence | ReadRest], + Unread = UnreadRest + ), + occurrences_partitioned(Occurrences, Singletons, ReadRest, UnreadRest). -goal_rewritten(Goal0, File, Goal) :- - arguments_of_abstracted(Goal0, File, Called, BottomUp), - goal_scheduled(BottomUp, Called, Goal). +singleton_arguments([], _). +singleton_arguments([Argument | Arguments], Singletons) :- + var(Argument), + variable_member(Argument, Singletons), + singleton_arguments(Arguments, Singletons). + +unread_checks([], []). +unread_checks([occurrence(id, Layer, Id, Handle) | Occurrences], + [(nonvar(Handle) -> true ; hash_consing:intern(Layer, Id)) | Checks]) :- + unread_checks(Occurrences, Checks). goal_scheduled([], Called, Called) :- !. @@ -1502,3 +1984,20 @@ user:term_expansion(Source, Rewritten) :- hash_consing:source_rewritten(Source, Rewritten). + +% The message of a constructor with no templates names the two ways to +% give it some. + +:- multifile prolog:error_message//1. + +prolog:error_message(resource_error(hash_consing_store)) --> + [ 'The hash_consing store passed the limit set by the flag'-[], nl, + 'hash_consing_store_limit, or this thread passed the growth budget'-[], nl, + 'set by hash_consing:store_growth_bounded/1; the store keeps every'-[], nl, + 'term interned so far.'-[] + ]. +prolog:error_message(existence_error(templates, Name/Arity)) --> + [ 'No templates for the constructor ~q in this process.'-[Name/Arity], nl, + 'Declare them with hash_consing:declared/1, or list them in the'-[], nl, + 'hash_consing:rewritten/1 directive of the files that use them.'-[] + ]. diff --git a/test/hash_consing.plt b/test/hash_consing.plt index 1e35f56..5c6342f 100644 --- a/test/hash_consing.plt +++ b/test/hash_consing.plt @@ -1,7 +1,7 @@ % THE TEST OF THE HASH_CONSING LIBRARY, run from the root of the pack as % swipl -p library=prolog --stack-limit=32m --table-space=32m \ % -g run_tests -t halt test/hash_consing.plt -% Ten plunit units, 65 tests. One unit per fixture file of +% Twelve plunit units, 86 tests. One unit per fixture file of % `hash_consing_fixtures/`, whose setup loads the fixture: its test % `snapshot` requires the errors the load raised, then the clauses the % load produced, rendered as text, to be byte for byte the file of @@ -11,10 +11,10 @@ % the unit `interrupted_intern` that an interning interrupted by a limit % leaves no key that fails to answer its term, and the unit `concurrency` % that threads sharing the store declare, intern and spell shapes as one -% thread would. Failing it is a defect by definition: what a rewrite -% produces -% and how `intern/2` answers are fixed by the module comment of -% prolog/hash_consing.pl, not measured. +% thread would, and the unit `store` how the store grows and how its limit +% and a thread's growth budget bound it. Failing it is a defect by +% definition: what a rewrite produces and how `intern/2` answers are fixed +% by the module comment of prolog/hash_consing.pl, not measured. % % A CLAUSE IS RENDERED WITH ITS BAKED IDS EXTERNALIZED, `baked(Term)` in % place of the Id, because a handle is an address of this process and would @@ -53,9 +53,10 @@ :- use_module(library(plunit)). :- use_module(library(hash_consing), - [intern/2, represented/2, is_id/1, externalized/2, internalized/3, declared/1]). + [intern/2, represented/2, is_id/1, externalized/2, internalized/3, declared/1, + store_property/1, store_growth_bounded/1]). :- use_module(library(aggregate), [aggregate_all/3]). -:- use_module(library(lists), [member/2]). +:- use_module(library(lists), [member/2, append/3]). :- use_module(library(readutil), [read_file_to_string/3]). :- use_module(library(listing), [portray_clause/1]). :- use_module(library(settings), [set_setting/2]). @@ -217,14 +218,13 @@ snapshot_read(Fixture, Snapshot) :- % % How many terms the store holds. store_count(Count) :- - nb_getval(hash_consing_store, Trie), - trie_property(Trie, value_count(Count)). + store_property(ids(Count)). %! spelling_count(-Count) % % How many shape atoms the library has spelled. spelling_count(Count) :- - nb_getval(hash_consing_spellings, Trie), + hash_consing:process_stores(_, Trie), trie_property(Trie, value_count(Count)). %! shape_indexed(+Head) @@ -274,38 +274,38 @@ numbered_template(Prefix, Number, Template) :- templates_declared_one_by_one(Templates, _) :- forall(member(Template, Templates), declared([Template])). -%! thread_stores(-Stores) -% -% The store and the spellings of this thread, the two global variables of -% prolog/hash_consing.pl. -thread_stores(stores(Store, Spellings)) :- - nb_getval(hash_consing_store, Store), - nb_getval(hash_consing_spellings, Spellings). - -%! thread_stores_installed(+Stores) -% -% Stores installed in this thread, which then interns into the same tries. -thread_stores_installed(stores(Store, Spellings)) :- - nb_setval(hash_consing_store, Store), - nb_setval(hash_consing_spellings, Spellings). - -%! terms_interned_with_stores(+Stores, +Numbers, +Worker, -Ids) +%! terms_interned(+Numbers, +Worker, -Ids) % % The Id of `concurrently_interned(Number)` for each of Numbers, interned by -% this thread into Stores. -terms_interned_with_stores(Stores, Numbers, _, Ids) :- - thread_stores_installed(Stores), +% this thread, which installed nothing: the store is the process's. +terms_interned(Numbers, _, Ids) :- maplist(number_interned, Numbers, Ids). +%! read_or_written(+Stored, +Worker, -Read) +% +% An even worker interns the stored terms again, Read their Ids; an odd one +% inserts new terms of the same constructor, Read `none`. +read_or_written(Stored, Worker, Read) :- + ( Worker mod 2 =:= 0 + -> maplist(read_beside_writers_interned, Stored, Read) + ; Low is 2001 + (Worker - 1) * 1250, + High is Low + 1249, + numlist(Low, High, New), + maplist(read_beside_writers_interned, New, _), + Read = none + ). + +read_beside_writers_interned(Number, Id) :- + intern(read_beside_writers(Number), Id). + number_interned(Number, Id) :- intern(concurrently_interned(Number), Id). -%! shapes_interned_with_stores(+Stores, +Numbers, +Worker, -Ids) +%! shapes_interned(+Numbers, +Worker, -Ids) % % The Id of `concurrently_shaped(shape_Number, Worker)` for each of Numbers: % a term of this thread's own, whose shape every thread spells alike. -shapes_interned_with_stores(Stores, Numbers, Worker, Ids) :- - thread_stores_installed(Stores), +shapes_interned(Numbers, Worker, Ids) :- maplist(shape_interned(Worker), Numbers, Ids). shape_interned(Worker, Number, Id) :- @@ -328,7 +328,10 @@ fixture(plain, 'hash_consing_fixtures/plain.pl', plain, fixture(inner_dispatch, 'hash_consing_fixtures/inner_dispatch.pl', inner_dispatch, []). fixture(reconfigured, 'hash_consing_fixtures/reconfigured.pl', reconfigured, []). fixture(patterns, 'hash_consing_fixtures/patterns.pl', patterns, - [kind/2, size/2, wrapped/2, first/2, built/2, unbound_built/1]). + [kind/2, size/2, wrapped/2, first/2, built/2, unbound_built/1, brought_in/2]). +fixture(layers, 'hash_consing_fixtures/layers.pl', layers, + [slot_made/2, slot_index/2, slot_read/2, linked_index/2, marked_name/2, + is_slot/1]). calculus([apply(*, _), lambda(_), variable(_), closure_a(_), closure_b]). deep_calculus([application(application(*, _), _), lambda(_), variable(_), closure(_)]). @@ -676,6 +679,14 @@ test(represented_decides_a_partial_layer, [nondet]) :- test(represented_raises_when_undecided, [error(instantiation_error)]) :- represented(app(_, _), _). +% The templates handed to internalized/3 in an opted-in file are kept as +% written, so the call interns what the directive does. +test(templates_in_a_library_call_are_kept) :- + patterns:brought_in(app(abs(ref(1)), ref(2)), Internal), + is_id(Internal), + patterns:kind(Internal, Kind), + Kind == redex. + :- end_tests(patterns). :- begin_tests(declarations, [timeout(1)]). @@ -769,9 +780,8 @@ test(a_constructor_declared_by_many_threads_is_registered_once) :- test(a_term_interned_by_many_threads_has_one_id) :- declared([concurrently_interned(_)]), numlist(1, 20000, Numbers), - thread_stores(Stores), numlist(1, 8, Workers), - concurrent_maplist(terms_interned_with_stores(Stores, Numbers), Workers, IdLists), + concurrent_maplist(terms_interned(Numbers), Workers, IdLists), IdLists = [Ids | OtherIdLists], forall(member(OtherIds, OtherIdLists), OtherIds == Ids). @@ -780,8 +790,238 @@ test(a_term_interned_by_many_threads_has_one_id) :- test(a_shape_spelled_by_many_threads_fails_no_interning) :- declared([concurrently_shaped(*, _)]), numlist(1, 2000, Numbers), - thread_stores(Stores), numlist(1, 8, Workers), - concurrent_maplist(shapes_interned_with_stores(Stores, Numbers), Workers, _). + concurrent_maplist(shapes_interned(Numbers), Workers, _). + +% Readers that intern stored terms while writers insert new ones of the +% same constructor each get the one Id of every term, and none raises. +test(readers_beside_writers_read_one_id_per_term) :- + declared([read_beside_writers(_)]), + numlist(1, 2000, Stored), + maplist(read_beside_writers_interned, Stored, StoredIds), + numlist(1, 8, Workers), + concurrent_maplist(read_or_written(Stored), Workers, ReadLists), + forall(member(Read, ReadLists), ( Read == none ; Read == StoredIds )), + numlist(2001, 12000, Written), + maplist(read_beside_writers_interned, Written, WrittenIds), + sort(WrittenIds, Distinct), + length(Written, Count), + length(Distinct, Count). :- end_tests(concurrency). + +% ---- layers ---- + +:- begin_tests(layers, [setup(fixture_loaded(layers)), timeout(1)]). + +test(snapshot, [true(Rendered == Snapshot)]) :- + fixture_rendered(layers, Rendered), + snapshot_read(layers, Snapshot). + +test(represented_makes_an_id_of_a_written_layer) :- + layers:slot_made(3, Slot), + intern(slot(3), Expected), + Slot == Expected. + +test(represented_reads_a_written_layer_back) :- + intern(slot(4), Slot), + layers:slot_index(Slot, Index), + Index == 4. + +test(a_layer_handed_out_is_matched_as_written) :- + intern(slot(5), Slot), + layers:slot_read(Slot, Index), + Index == 5. + +test(a_listed_constructor_inside_a_layer_is_an_id) :- + intern(slot(6), Slot), + intern(link(Slot, Slot), Link), + layers:linked_index(Link, Index), + Index == 6. + +test(a_head_layer_matches_a_plain_layer) :- + layers:marked_name(marked(name), Name), + Name == name. + +test(a_head_layer_does_not_match_an_id, [fail]) :- + intern(marked(name), Marked), + layers:marked_name(Marked, _). + +test(an_unread_occurrence_matches_an_id_of_its_constructor) :- + intern(slot(7), Slot), + layers:is_slot(Slot). + +test(an_unread_occurrence_rejects_another_id, [fail]) :- + intern(marked(name), Marked), + layers:is_slot(Marked). + +test(an_unread_occurrence_left_unbound_raises, [error(instantiation_error)]) :- + layers:is_slot(_). + +test(an_unknown_option_raises, [error(domain_error(rewritten_option, unknown))]) :- + hash_consing:rewritten_with_options([], [unknown], hash_consing:rewritten/2). + +test(a_skeleton_without_a_layer_raises, [error(domain_error(layer_skeleton, read(_)))]) :- + hash_consing:rewritten_with_options([], [layer_arguments([read(_)])], hash_consing:rewritten/2). + +:- end_tests(layers). + +% budget_spent_by_this_thread(+Main): sends Main `outcome(raised)` when +% this thread, with a budget of one byte, may insert one new term but not +% a second, and `outcome(within_budget)` when it may insert both. + +budget_spent_by_this_thread(Main) :- + store_growth_bounded(1), + intern(grown_by_one_thread(1), _), + catch(( intern(grown_by_one_thread(2), _), Outcome = within_budget ), + error(resource_error(hash_consing_store), _), + Outcome = raised), + intern(grown_by_one_thread(1), _), + thread_send_message(Main, outcome(Outcome)). + +% budget_inherited(+Main): with a budget of one byte, this thread spends +% it on one new term and creates a thread that runs +% budget_spent_by_this_thread/1 without setting a budget of its own; that +% thread may insert one new term, its count being zero, but not a second, +% and sends Main its outcome. + +budget_inherited(Main) :- + store_growth_bounded(1), + intern(grown_by_an_inheriting_thread(0), _), + thread_create(budget_spent_by_inheriting_thread(Main), Thread, []), + thread_join(Thread, true). + +budget_spent_by_inheriting_thread(Main) :- + intern(grown_by_an_inheriting_thread(1), _), + catch(( intern(grown_by_an_inheriting_thread(2), _), Outcome = within_budget ), + error(resource_error(hash_consing_store), _), + Outcome = raised), + thread_send_message(Main, outcome(Outcome)). + +% grown_in_parallel_interned(+Group, +Number): `grown_in_parallel(Group, +% Number)` interned. + +grown_in_parallel_interned(Group, Number) :- + intern(grown_in_parallel(Group, Number), _). + +% budgeted_halves(+Main, +Budget, +Numbers): with a budget of Budget bytes, +% this thread interns the first half of Numbers, tells Main, waits for +% `go_on`, interns the second half, and sends Main `outcome(raised)` if an +% insertion raised, `outcome(within_budget)` otherwise. + +budgeted_halves(Main, Budget, Numbers) :- + store_growth_bounded(Budget), + length(Numbers, Count), + Half is Count // 2, + length(FirstHalf, Half), + append(FirstHalf, SecondHalf, Numbers), + maplist(grown_in_parallel_interned(budgeted), FirstHalf), + thread_send_message(Main, first_half_interned), + thread_get_message(go_on), + catch(( maplist(grown_in_parallel_interned(budgeted), SecondHalf), + Outcome = within_budget ), + error(resource_error(hash_consing_store), _), + Outcome = raised), + thread_send_message(Main, outcome(Outcome)). + +:- begin_tests(store, [timeout(1)]). + +% A new term adds one Id to the store and its nodes to the trie; a term +% interned again adds nothing. +test(a_new_term_adds_one_id) :- + declared([counted_in_the_store(_)]), + store_property(ids(Before)), + intern(counted_in_the_store(1), Id), + intern(counted_in_the_store(1), Again), + store_property(ids(After)), + store_property(nodes(Nodes)), + store_property(bytes(Bytes)), + Again == Id, + After =:= Before + 1, + Nodes >= After, + Bytes > 0. + +% A thread that installed nothing reads the Id another thread made. +test(another_thread_reads_an_id_without_installing) :- + declared([read_by_another_thread(_)]), + intern(read_by_another_thread(1), Id), + thread_create(( intern(Term, Id), Term == read_by_another_thread(1) ), Thread, []), + thread_join(Thread, Status), + Status == true. + +% The error for a constructor with no templates names declared/1. +test(the_missing_templates_message_names_declared, + [true(sub_string(Text, _, _, _, "hash_consing:declared/1"))]) :- + catch(intern(no_templates_anywhere(1), _), Error, true), + message_text(Error, Text). + +% message_text(+Message, -Text): the text print_message/2 would print. +message_text(Message, Text) :- + '$messages':translate_message(Message, Lines, []), + with_output_to(string(Text), print_message_lines(current_output, '', Lines)). + +% A store past its limit raises a resource error on the next insertion and +% still answers the terms it holds. +test(a_store_past_its_limit_raises) :- + declared([bounded_in_the_store(_)]), + intern(bounded_in_the_store(0), Held), + store_property(bytes(Bytes)), + Limit is Bytes - 1, + setup_call_cleanup( + set_prolog_flag(hash_consing_store_limit, Limit), + ( catch(( intern(bounded_in_the_store(1), _), Raised = false ), + error(resource_error(hash_consing_store), _), + Raised = true), + intern(bounded_in_the_store(0), Again) ), + set_prolog_flag(hash_consing_store_limit, infinite)), + Raised == true, + Again == Held. + +% A thread whose budget is spent raises on its next insertion; a term +% already in the store is still read, and other threads are not bounded. + +test(a_thread_past_its_growth_budget_raises) :- + declared([grown_by_one_thread(_)]), + thread_self(Main), + thread_create(budget_spent_by_this_thread(Main), Thread, []), + thread_join(Thread, true), + thread_get_message(outcome(Outcome)), + Outcome == raised, + intern(grown_by_one_thread(1000), _). + +% Two threads share the store; the first sets a budget, the second has +% none. The second inserts 2000 terms between two halves of the first's +% insertions, and the first's budget, room for its own terms only, is not +% charged with them. + +test(parallel_threads_do_not_charge_each_other) :- + declared([grown_in_parallel(_, _)]), + numlist(1, 50, Numbers), + store_property(bytes(BytesBefore)), + maplist(grown_in_parallel_interned(measured), Numbers), + store_property(bytes(BytesAfter)), + Budget is 2 * (BytesAfter - BytesBefore), + thread_self(Main), + thread_create(budgeted_halves(Main, Budget, Numbers), Budgeted, []), + thread_get_message(first_half_interned), + thread_create(forall(between(1, 2000, Number), + grown_in_parallel_interned(unbudgeted, Number)), + Unbudgeted, []), + thread_join(Unbudgeted, true), + thread_send_message(Budgeted, go_on), + thread_join(Budgeted, true), + thread_get_message(outcome(Outcome)), + Outcome == within_budget. + +% A thread created by a thread with a budget inherits the budget with a +% count of its own from zero, as it inherits `stack_limit`. + +test(a_new_thread_inherits_the_budget_with_its_own_count) :- + declared([grown_by_an_inheriting_thread(_)]), + thread_self(Main), + thread_create(budget_inherited(Main), Thread, []), + thread_join(Thread, true), + thread_get_message(outcome(Outcome)), + Outcome == raised. + +:- end_tests(store). diff --git a/test/hash_consing_fixtures/layer_reader.pl b/test/hash_consing_fixtures/layer_reader.pl new file mode 100644 index 0000000..3e2361a --- /dev/null +++ b/test/hash_consing_fixtures/layer_reader.pl @@ -0,0 +1,8 @@ +% Fixture of test/hash_consing.plt: a module that does not opt in and +% hands out the plain layer of an Id, as a framework's reader of one layer +% does; `layers.pl` calls it. +:- module(layer_reader, [stored_layer/2]). +:- use_module(library(hash_consing), []). + +stored_layer(Id, Layer) :- + hash_consing:intern(Layer, Id). diff --git a/test/hash_consing_fixtures/layers.pl b/test/hash_consing_fixtures/layers.pl new file mode 100644 index 0000000..c17eabe --- /dev/null +++ b/test/hash_consing_fixtures/layers.pl @@ -0,0 +1,33 @@ +% Fixture of test/hash_consing.plt: layer positions. The first argument of +% represented/2, and the positions `layer_arguments` names, keep the +% constructor written there as a plain layer; its arguments are rewritten +% as anywhere else. +:- module(layers, [slot_made/2, slot_index/2, slot_read/2, linked_index/2, marked_name/2, + is_slot/1]). +:- use_module(library(hash_consing), []). +:- use_module(layer_reader, [stored_layer/2]). +:- hash_consing:rewritten([slot(_), link(_, _), marked(_)], + [layer_arguments([stored_layer(_, layer), marked_name(layer, _)])]). + +% The layer `slot(Index)` represented, and read back from an Id. +slot_made(Index, Slot) :- + hash_consing:represented(slot(Index), Slot). +slot_index(Slot, Index) :- + hash_consing:represented(slot(Index), Slot). + +% The plain layer a module that does not opt in hands out, matched as +% written. +slot_read(Slot, Index) :- + stored_layer(Slot, slot(Index)). + +% A listed constructor inside a layer is an Id, as anywhere else. +linked_index(Link, Index) :- + stored_layer(Link, link(slot(Index), _)). + +% A head whose first argument is a layer. +marked_name(marked(Name), Name). + +% An unread occurrence: its argument occurs nowhere else, so the goal +% matches the Id pattern and reads nothing back. +is_slot(Value) :- + Value = slot(_). diff --git a/test/hash_consing_fixtures/patterns.pl b/test/hash_consing_fixtures/patterns.pl index 9c68b13..e4ae4f5 100644 --- a/test/hash_consing_fixtures/patterns.pl +++ b/test/hash_consing_fixtures/patterns.pl @@ -2,7 +2,7 @@ % `app/2` has three templates, tried in order, and an application that none % of them matches stays a plain compound; the occurrences below fall in the % three classes of the rewrite. -:- module(patterns, [kind/2, size/2, wrapped/2, first/2, built/2, unbound_built/1]). +:- module(patterns, [kind/2, size/2, wrapped/2, first/2, built/2, unbound_built/1, brought_in/2]). :- include(patterns_templates). % Must intern, every instance taking the first template: the shape `abs/1` @@ -43,3 +43,9 @@ % Undetermined in a body goal and still undecided when it is called. unbound_built(Built) :- Built = app(_, abs(ref(0))). + +% A call of the library whose first argument is templates keeps them as +% written: they are data the library reads, not terms to intern. +brought_in(External, Internal) :- + hash_consing:internalized([app(abs(_), _), app(app(*, _), _), app(_, ref(_)), abs(_), ref(_)], + External, Internal). diff --git a/test/hash_consing_snapshots/layers.txt b/test/hash_consing_snapshots/layers.txt new file mode 100644 index 0000000..843bb4e --- /dev/null +++ b/test/hash_consing_snapshots/layers.txt @@ -0,0 +1,29 @@ +predicate(slot_made/2) +slot_made(A, B) :- + hash_consing:represented(slot(A), B). +predicate(slot_index/2) +slot_index(A, B) :- + hash_consing:represented(slot(B), A). +predicate(slot_read/2) +slot_read(A, B) :- + stored_layer(A, slot(B)). +predicate(linked_index/2) +linked_index(A, B) :- + ( ground([B]) + -> hash_consing:intern(slot(B), '__hash_consed_slot/1'(C)), + stored_layer(A, link('__hash_consed_slot/1'(C), _)) + ; ( ground(slot(B)) + -> hash_consing:intern(slot(B), '__hash_consed_slot/1'(C)) + ; true + ), + stored_layer(A, link('__hash_consed_slot/1'(C), _)), + hash_consing:intern(slot(B), '__hash_consed_slot/1'(C)) + ). +predicate(marked_name/2) +marked_name(marked(A), A). +predicate(is_slot/1) +is_slot('__hash_consed_slot/1'(A)) :- + ( nonvar(A) + -> true + ; hash_consing:intern(slot(_), '__hash_consed_slot/1'(A)) + ). diff --git a/test/hash_consing_snapshots/patterns.txt b/test/hash_consing_snapshots/patterns.txt index 6b36d57..bd04f70 100644 --- a/test/hash_consing_snapshots/patterns.txt +++ b/test/hash_consing_snapshots/patterns.txt @@ -1,8 +1,7 @@ predicate(kind/2) kind('__hash_consed_app/2'('abs/1', A), redex) :- ( nonvar(A) - -> hash_consing:intern(app('__hash_consed_abs/1'(B), C), '__hash_consed_app/2'('abs/1', A)), - hash_consing:intern(abs(D), '__hash_consed_abs/1'(B)) + -> hash_consing:intern(app('__hash_consed_abs/1'(B), C), '__hash_consed_app/2'('abs/1', A)) ; ( nonvar(A) -> hash_consing:intern(app('__hash_consed_abs/1'(B), C), '__hash_consed_app/2'('abs/1', A)) ; true @@ -33,8 +32,7 @@ kind('__hash_consed_app/2'('abs/1', A), redex) :- kind('__hash_consed_app/2'('app/2(abs/1)', A), redex_under_an_application) :- ( nonvar(A) -> hash_consing:intern(app('__hash_consed_app/2'('abs/1', B), C), '__hash_consed_app/2'('app/2(abs/1)', A)), - hash_consing:intern(app('__hash_consed_abs/1'(D), E), '__hash_consed_app/2'('abs/1', B)), - hash_consing:intern(abs(F), '__hash_consed_abs/1'(D)) + hash_consing:intern(app('__hash_consed_abs/1'(D), E), '__hash_consed_app/2'('abs/1', B)) ; ( nonvar(A) -> hash_consing:intern(app('__hash_consed_app/2'('abs/1', B), C), '__hash_consed_app/2'('app/2(abs/1)', A)) ; true @@ -77,9 +75,7 @@ kind('__hash_consed_app/2'('app/2(abs/1)', A), redex_under_an_application) :- ). kind('__hash_consed_app/2'('ref/1', A), stuck) :- ( nonvar(A) - -> hash_consing:intern(app('__hash_consed_ref/1'(B), '__hash_consed_ref/1'(C)), '__hash_consed_app/2'('ref/1', A)), - hash_consing:intern(ref(D), '__hash_consed_ref/1'(C)), - hash_consing:intern(ref(E), '__hash_consed_ref/1'(B)) + -> hash_consing:intern(app('__hash_consed_ref/1'(B), '__hash_consed_ref/1'(C)), '__hash_consed_app/2'('ref/1', A)) ; ( nonvar(A) -> hash_consing:intern(app('__hash_consed_ref/1'(B), '__hash_consed_ref/1'(C)), '__hash_consed_app/2'('ref/1', A)) ; true @@ -123,8 +119,7 @@ kind('__hash_consed_app/2'('ref/1', A), stuck) :- kind(app('__hash_consed_ref/1'(A), '__hash_consed_abs/1'(B)), plain) :- ( nonvar(A), nonvar(B) - -> hash_consing:intern(abs(C), '__hash_consed_abs/1'(B)), - hash_consing:intern(ref(D), '__hash_consed_ref/1'(A)) + -> true ; ( nonvar(B) -> hash_consing:intern(abs(C), '__hash_consed_abs/1'(B)) ; true @@ -216,7 +211,7 @@ size('__hash_consed_abs/1'(A), B) :- ). size('__hash_consed_ref/1'(A), 1) :- ( nonvar(A) - -> hash_consing:intern(ref(B), '__hash_consed_ref/1'(A)) + -> true ; ( nonvar(A) -> hash_consing:intern(ref(B), '__hash_consed_ref/1'(A)) ; true @@ -323,3 +318,6 @@ unbound_built(A) :- A=C, hash_consing:represented(app(B, baked(abs(ref(0)))), C) ). +predicate(brought_in/2) +brought_in(A, B) :- + hash_consing:internalized([app(abs(_), _), app(app(*, _), _), app(_, ref(_)), abs(_), ref(_)], A, B). diff --git a/test/hash_consing_snapshots/spines.txt b/test/hash_consing_snapshots/spines.txt index 759fb73..5fed0d8 100644 --- a/test/hash_consing_snapshots/spines.txt +++ b/test/hash_consing_snapshots/spines.txt @@ -1,8 +1,7 @@ predicate(head/2) head('__hash_consed_application/2'('application/2(lambda/1)', A), redex_under_an_application) :- ( nonvar(A) - -> hash_consing:intern(application(application('__hash_consed_lambda/1'(B), C), D), '__hash_consed_application/2'('application/2(lambda/1)', A)), - hash_consing:intern(lambda(E), '__hash_consed_lambda/1'(B)) + -> hash_consing:intern(application(application('__hash_consed_lambda/1'(B), C), D), '__hash_consed_application/2'('application/2(lambda/1)', A)) ; ( nonvar(A) -> hash_consing:intern(application(application('__hash_consed_lambda/1'(B), C), D), '__hash_consed_application/2'('application/2(lambda/1)', A)) ; true @@ -32,8 +31,7 @@ head('__hash_consed_application/2'('application/2(lambda/1)', A), redex_under_an ). head('__hash_consed_application/2'('application/2(closure/1)', A), compiled_redex_under_an_application) :- ( nonvar(A) - -> hash_consing:intern(application(application('__hash_consed_closure/1'(B), C), D), '__hash_consed_application/2'('application/2(closure/1)', A)), - hash_consing:intern(closure(E), '__hash_consed_closure/1'(B)) + -> hash_consing:intern(application(application('__hash_consed_closure/1'(B), C), D), '__hash_consed_application/2'('application/2(closure/1)', A)) ; ( nonvar(A) -> hash_consing:intern(application(application('__hash_consed_closure/1'(B), C), D), '__hash_consed_application/2'('application/2(closure/1)', A)) ; true @@ -63,7 +61,7 @@ head('__hash_consed_application/2'('application/2(closure/1)', A), compiled_rede ). head(application('__hash_consed_lambda/1'(A), _), redex) :- ( nonvar(A) - -> hash_consing:intern(lambda(B), '__hash_consed_lambda/1'(A)) + -> true ; ( nonvar(A) -> hash_consing:intern(lambda(B), '__hash_consed_lambda/1'(A)) ; true