Hi,

here is the full structure sharing analysis system, meant to be a part of the
CTGC system. The analysis system is a rewrite of what was once kept in the
separate reuse-branch of the compiler. Some of the essential routines for
handling sharing information have been rewritten and will ask some further
testing, but I wanted to submit this for review so that things can get going.

Some remarks: 
- the system is activated using the compiler option structure-sharing. Widening
is also implemented, using the option structure-sharing-widening, with some
integer indicating the threshold. 
- not yet implemented: user annotated structure sharing pragma, to be used
mainly for annotating pieces of foreign code in the library. That will be a
separate diff. 

I hope I have documented my code sufficiently... 
regards, 
Nancy


===================================================================


Estimated hours taken: 120
Branches: main

Implementation of the structure sharing analysis (part of the CTGC system). 

compiler/ctgc.datastruct.m:
	(new file) Manipulation of a datastruct (defined in prog_data.m)

compiler/ctgc.selector.m:
	(new file) Manipulation of a selector (defined in prog_data.m)

compiler/ctgc.fixpoint_table.m:
	(new file) Definition of a generic fixpoint table to be used by the
	structure sharing analysis framework as well as the structure reuse
	part. 

compiler/ctgc.util.m:
	(new file) General operations valid for both structure sharing
	analysis as structure reuse analysis. 
	
compiler/ctgc.m:
	Included additional modules. 	

compiler/structure_sharing.analysis.m:
compiler/structure_sharing.domain.m:
compiler/structure_sharing.m:
	Structure sharing analysis and domain. 

compiler/add_pragma.m:
compiler/make_hlds_passes.m:
compiler/mercury_to_mercury.m:
compiler/module_qual.m:
compiler/modules.m:
compiler/prog_io_pragma.m:
compiler/prog_item.m:
compiler/recompilation.version.m:
compiler/trans_opt.m:
	Added structure_sharing pragma and ways to handle it. 

compiler/handle_options.m:
	- Structure sharing analysis implies transitive optimization. 
	- Added character "S" to be used to dump structure sharing related
	information in the hlds_dump-files.

compiler/hlds_out.m:
	Dump structure sharing information. 

compiler/hlds_pred.m:
	Store structure sharing information in proc_info.

compiler/mercury_compile.m:
	Perform structure sharing when creating .opt, .trans-opt files, and
	when compiling to c. 

compiler/options.m:
	New options: structure-sharing and structure-sharing-widening.

compiler/parse_tree.m:
compiler/prog_ctgc.m:
	(new file) This module contains printing/parsing and renaming
	routines for handling the public representation used for 
	structure sharing information. 

compiler/prog_data.m:
	Public representation for structure sharing information. 


Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.21
diff -u -d -r1.21 add_pragma.m
--- compiler/add_pragma.m	1 Feb 2006 04:02:45 -0000	1.21
+++ compiler/add_pragma.m	14 Feb 2006 09:33:31 -0000
@@ -52,6 +52,11 @@
     maybe(pragma_termination_info)::in, prog_context::in,
     module_info::in, module_info::out, io::di, io::uo) is det.
 
+:- pred add_pragma_structure_sharing(pred_or_func::in, sym_name::in,
+    list(mer_mode)::in, list(prog_var)::in, list(mer_type)::in, 
+    maybe(structure_sharing_domain)::in, prog_context::in,
+    module_info::in, module_info::out, io::di, io::uo) is det.
+
     % module_add_pragma_import:
     %
     % Handles `pragma import' declarations, by figuring out which predicate
@@ -129,6 +134,7 @@
 :- import_module parse_tree.modules.
 :- import_module parse_tree.prog_foreign.
 :- import_module parse_tree.prog_io.
+:- import_module parse_tree.prog_ctgc.
 :- import_module parse_tree.prog_out.
 :- import_module parse_tree.prog_type.
 :- import_module parse_tree.prog_type_subst.
@@ -337,6 +343,8 @@
             Context, check_termination, [terminates, does_not_terminate],
             !ModuleInfo, !IO)
     ;
+        Pragma = structure_sharing(_, _, _, _, _, _)
+    ;
         Pragma = mode_check_clauses(Name, Arity),
         add_pred_marker("mode_check_clauses", Name, Arity, ImportStatus,
             Context, mode_check_clauses, [], !ModuleInfo, !IO),
@@ -1129,6 +1137,92 @@
         %        "`:- pragma termination2_info' declaration", !IO),
         %   module_info_incr_errors(!ModuleInfo)
     ).
+
+%-----------------------------------------------------------------------------%
+
+add_pragma_structure_sharing(_PredOrFunc, _SymName, _ModeList, _HeadVars,
+        _Types, no, _Context, !ModuleInfo, !IO).
+add_pragma_structure_sharing(PredOrFunc, SymName, ModeList, HeadVars,
+        Types, yes(SharingDomain), Context, !ModuleInfo, !IO):-
+    module_info_get_predicate_table(!.ModuleInfo, Preds),
+    list__length(ModeList, Arity),
+    (
+        predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
+            PredOrFunc, SymName, Arity, PredIds),
+        PredIds = [_ | _]
+    ->
+        ( PredIds = [PredId] ->
+            module_info_preds(!.ModuleInfo, PredTable0),
+            map__lookup(PredTable0, PredId, PredInfo0),
+            pred_info_procedures(PredInfo0, ProcTable0),
+            map__to_assoc_list(ProcTable0, ProcList),
+            (
+                get_procedure_matching_declmodes(ProcList, ModeList,
+                    !.ModuleInfo, ProcId)
+            ->
+                map__lookup(ProcTable0, ProcId, ProcInfo0),
+               
+                % Rename headvars/types to those used in the proc_info. 
+                proc_info_headvars(ProcInfo0, ProcHeadVars), 
+
+                % As the HeadVars recorded in the pragma may contain additional
+                % vars (e.g. typeinfos), and in the same time ProcHeadVars does
+                % not, make sure to remove all TypeInfo-vars from HeadVars, 
+                % the same for the list Types.
+                Diff = list.length(HeadVars) - list.length(ProcHeadVars),
+                (
+                    list.drop(Diff, HeadVars, RemHeadVars0), 
+                    list.drop(Diff, Types, RemTypes0)
+                -> 
+                    RemHeadVars = RemHeadVars0, 
+                    RemTypes = RemTypes0
+                ;
+                    unexpected(this_file, "Impossible situation.")
+                ),
+                map__from_corresponding_lists(RemHeadVars, ProcHeadVars,
+                    MapHeadVars), 
+                pred_info_arg_types(PredInfo0, ArgTypes),
+                TypeSubst0 = map.init, 
+                (
+                    type_unify_list(RemTypes, ArgTypes, [], TypeSubst0, 
+                        TypeSubst1)
+                ->
+                    TypeSubst = TypeSubst1
+                ;
+                    TypeSubst = TypeSubst0
+                ),
+                rename_structure_sharing_domain(MapHeadVars, TypeSubst,
+                    SharingDomain, RenamedSharingDomain), 
+                proc_info_set_structure_sharing(RenamedSharingDomain, 
+                    ProcInfo0, ProcInfo), 
+                map__det_update(ProcTable0, ProcId, ProcInfo, ProcTable),
+                pred_info_set_procedures(ProcTable, PredInfo0, PredInfo),
+                map__det_update(PredTable0, PredId, PredInfo, PredTable),
+                module_info_set_preds(PredTable, !ModuleInfo)
+            ;
+                module_info_incr_errors(!ModuleInfo),
+                Pieces = [words("Error: `:- pragma structure_sharing'"),
+                    words("declaration for undeclared mode of"),
+                    simple_call_id(PredOrFunc - SymName/Arity), suffix(".")],
+                write_error_pieces(Context, 0, Pieces, !IO)
+            )
+        ;
+            module_info_incr_errors(!ModuleInfo),
+            Pieces = [words("Error: ambiguous predicate name"),
+                simple_call_id(PredOrFunc - SymName/Arity),
+                words("in"), fixed("`pragma structure_sharing'.")],
+            write_error_pieces(Context, 0, Pieces, !IO)
+        )
+    ;
+        % XXX This happens in `.trans_opt' files sometimes --
+        % so just ignore it
+        true
+        %   undefined_pred_or_func_error(SymName, Arity, Context,
+        %       "`:- pragma structure_sharing' declaration",
+        %       !IO),
+        %   module_info_incr_errors(!ModuleInfo)
+    ).
+
 
 %-----------------------------------------------------------------------------%
 
Index: compiler/ctgc.datastruct.m
===================================================================
RCS file: compiler/ctgc.datastruct.m
diff -N compiler/ctgc.datastruct.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ compiler/ctgc.datastruct.m	14 Feb 2006 09:33:31 -0000
@@ -0,0 +1,130 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2006 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: ctgc.datastruct.m
+% Main authors: nancy
+%
+% Definition of predicates and functions for the manipulation of 
+% datastructures. 
+%-----------------------------------------------------------------------------%
+
+:- module transform_hlds.ctgc.datastruct.
+
+:- interface.
+
+:- import_module parse_tree.prog_data.
+:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_pred.
+
+:- import_module list.
+
+	% Create an initial top-datastruct of the given variable.
+	%
+:- func init(prog_var) = datastruct.
+:- func init(prog_var, selector) = datastruct.
+:- func init(prog_var, cons_id, int) = datastruct.
+
+	% Verify whether the given datastructs are idenitical.
+	%
+:- pred equal(datastruct::in, datastruct::in) is semidet.
+
+	% Select a subterm of the given datastructure using the specified
+	% selector. 
+	% It is assumed that the selector is a valid selector for that
+	% datastructure. 
+	%
+:- pred termshift(selector::in, datastruct::in, datastruct::out) is det.
+:- func termshift(selector, datastruct) = datastruct. 
+
+	% Normalize the representation of the datastructure.
+	% (proc_info is needed to obtain the type of the variable of the
+	% datastructure). 
+	% The selector of a datastruct is normalized
+	% iff none of the term nodes met on the path to the actual selected
+	% term by the selector has the same type as the selected node. 
+	%
+:- func normalize(module_info, proc_info, datastruct) = datastruct.
+
+	% Normalize the representation of the datastructure using its
+	% type information. 
+	%
+:- pred normalize_with_type_information(module_info::in, mer_type::in,
+	datastruct::in, datastruct::out) is det.
+:- func normalize_with_type_information(module_info, mer_type, 
+	datastruct) = datastruct.
+
+:- pred subsumed_by(module_info::in, proc_info::in, datastruct::in, 
+	datastruct::in, selector::out) is semidet.
+:- pred subsumed_by(module_info::in, proc_info::in, datastruct::in, 
+	datastruct::in) is semidet.
+:- pred subsumed_by_list(module_info::in, proc_info::in, datastruct::in,
+	list(datastruct)::in) is semidet.
+
+:- pred apply_widening(module_info::in, proc_info::in, datastruct::in, 
+	datastruct::out) is det.
+
+:- implementation.
+
+:- import_module transform_hlds.ctgc.selector.
+
+:- import_module map.
+
+
+init(V) = init(V, []).
+init(V, Sel) = selected_cel(V, Sel). 
+init(V, ConsId, Int) = init(V, selector.init(ConsId, Int)).
+
+equal(D1, D2) :- D1 = D2. 
+
+termshift(Sel, Data0, Data) :- 
+	DSel = Data0 ^ sc_selector, 
+	selector.termshift(DSel, Sel, NewSel), 
+	Data = Data0 ^ sc_selector := NewSel.
+termshift(Sel, Data0) = Data :- 
+	termshift(Sel, Data0, Data).
+
+normalize_with_type_information(ModuleInfo, Type, !Datastruct) :- 
+	DSel0 = !.Datastruct ^ sc_selector, 
+	normalize_with_type_information(ModuleInfo, Type, DSel0, DSel), 
+	!:Datastruct = !.Datastruct ^ sc_selector := DSel. 
+
+normalize_with_type_information(ModuleInfo, Type, Data0) = Data :- 
+	normalize_with_type_information(ModuleInfo, Type, Data0, Data).
+
+normalize(ModuleInfo, ProcInfo, Data0) = Data :- 
+	Var = Data0 ^ sc_var, 
+	proc_info_vartypes(ProcInfo, VarTypes), 
+	map.lookup(VarTypes, Var, Type), 
+	Data = normalize_with_type_information(ModuleInfo, Type, Data0).
+
+subsumed_by(ModuleInfo, ProcInfo, Data1, Data2, Extension) :- 
+	Var = Data1 ^ sc_var,
+	Var = Data2 ^ sc_var, 
+	Sel1 = Data1 ^ sc_selector, 
+	Sel2 = Data2 ^ sc_selector, 
+	proc_info_vartypes(ProcInfo, VarTypes), 
+	map.lookup(VarTypes, Var, Type), 
+	ctgc.selector.subsumed_by(ModuleInfo, Sel1, Sel2, Type, Extension).
+
+subsumed_by(ModuleInfo, ProcInfo, Data1, Data2) :- 
+	subsumed_by(ModuleInfo, ProcInfo, Data1, Data2, _).
+
+subsumed_by_list(ModuleInfo, ProcInfo, Data0, [Data|Rest]):- 
+	(
+		subsumed_by(ModuleInfo, ProcInfo, Data0, Data)
+	;
+		subsumed_by_list(ModuleInfo, ProcInfo, Data0, Rest)
+	).
+
+apply_widening(ModuleInfo, ProcInfo, !Data) :- 
+	Var = !.Data ^ sc_var, 
+	Sel0 = !.Data ^ sc_selector, 
+	proc_info_vartypes(ProcInfo, VarTypes), 
+	map.lookup(VarTypes, Var, Type),
+	apply_widening(ModuleInfo, Type, Sel0, Sel), 
+	!:Data = init(Var, Sel).
+
+:- end_module transform_hlds.ctgc.datastruct.
Index: compiler/ctgc.fixpoint_table.m
===================================================================
RCS file: compiler/ctgc.fixpoint_table.m
diff -N compiler/ctgc.fixpoint_table.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ compiler/ctgc.fixpoint_table.m	14 Feb 2006 09:33:32 -0000
@@ -0,0 +1,213 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2006 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: ctgc.fixpoint_table.m
+% Main author: nancy.
+%
+% This module defines a generic table to be used for fixpoint computations. 
+% The purpose of this table is mainly to map pred_proc_id's onto abstract
+% substitutions representing either structure sharing or structure reuse.
+%
+%-----------------------------------------------------------------------------%
+
+:- module transform_hlds.ctgc.fixpoint_table.
+
+:- interface.
+
+:- import_module list.
+
+:- type fixpoint_table(K, E). 
+
+	% Initialise the table.
+	% The first parameter is a function that produces the initial value
+	% for each of the keys that are to be inserted into the table. 
+:- func init(func(K) = E, list(K)) = fixpoint_table(K, E).
+
+	% Inform the table that a new run has begun.
+	%
+:- pred new_run(fixpoint_table(K, E)::in, fixpoint_table(K, E)::out) is det.
+
+	% Which run of the fix point are we up to?
+	%
+:- func which_run(fixpoint_table(K, E)) = int.
+
+	% Check whether a fixpoint has been reached.
+	%
+:- pred fixpoint_reached(fixpoint_table(K, E)::in) is semidet.
+
+	% Return a short description of the state of the fixpoint table.
+	%
+:- func description(fixpoint_table(K, E)) = string.
+
+	% Check whether the entries are recursive.
+	%
+:- pred is_recursive(fixpoint_table(K,E)::in) is semidet.
+
+	% Add a new element (E) associated with key (K) to the table.
+	%   - if an element is already recorded with that key:
+	%      * if the new value is subsumed by the existing value, then
+	%      	 a fixpoint is obtained as far as this key is concerned.
+	%      * if the values are different, fixpoint is not reached yet, 
+	%	 and the new value is recorded instead of the old one. 
+	%   - if the key has not yet any value associated to it, add it
+	%     to the table (which does not change the stability of the
+	%     table) 
+	% add( EqualityTest, Key, Element, TableIn, TableOut).
+	%
+:- pred add(pred(E, E), K, E, fixpoint_table(K, E), fixpoint_table(K, E)).
+:- mode add(pred(in, in) is semidet, in, in, in, out) is det.
+
+	% Retrieve an element E associated with key K from the table.
+	% This operation changes the state of the table if the
+	% element _is_ present in the table. This means we are facing
+	% a recursive calltree. If the key is not an element of the
+	% allowed keys, then the procedure fails.
+	%
+:- pred get(K::in, E::out, fixpoint_table(K, E)::in, 
+	fixpoint_table(K, E)::out) is semidet.
+
+	% Retrieve an element E associated with key K from the table. 
+	% The operation reports a software error when the element is not
+	% present. 
+	%
+:- func get_final(K, fixpoint_table(K,E)) = E.
+
+	% Same as get_final, but the predicate fails instead of aborting when
+	% the element is not present. 
+	%
+:- func get_final_semidet(K, fixpoint_table(K,E)) = E is semidet.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation. 
+
+:- import_module libs.compiler_util.
+
+:- import_module bool.
+:- import_module int.
+:- import_module list.
+:- import_module map.
+:- import_module require.
+
+:- type fixpoint_table(K, E)
+	--->	ft(  
+		     keys	:: list(K),	% list of allowed keys
+		     run	:: int,		% number of runs
+		     recursive	:: bool,	% is recursive or not
+		     mapping 	:: map(K, fp_entry(E))
+		).
+
+:- type fp_entry(E) 
+	--->	entry(
+			bool, 	% stability: yes = stable, no = unstable
+			E). 
+		   
+:- func fp_entry_init(E) = fp_entry(E).
+:- func fp_entry_stability(fp_entry(E)) = bool. 
+:- func fp_entry_elem(fp_entry(E)) = E. 
+:- func fp_entry_init(bool, E) = fp_entry(E). 
+fp_entry_init(Elem) = entry(no, Elem).  
+fp_entry_init(Bool, Elem) = entry(Bool, Elem). 
+fp_entry_stability(entry(S, _)) = S. 
+fp_entry_elem(entry(_, Elem)) = Elem. 
+
+init(InitFunction, Ks) =  ft(Ks, Run, IsRecursive, Map) :- 
+	Run = 0,
+	IsRecursive = no,
+	map__init(Map0),
+	list__foldl(
+		(pred(K::in, M0::in, M::out) is det :- 
+			E = InitFunction(K),
+			map__det_insert(M0, K, fp_entry_init(E), M)
+		),
+		Ks, 
+		Map0, 
+		Map
+	).
+
+new_run(T0, T0 ^ run := T0 ^ run + 1).
+which_run(T0) = T0 ^ run.
+
+is_recursive(T) :- T ^ recursive = yes.
+
+fixpoint_reached(T) :- 
+	(
+		T ^ recursive = yes
+	->
+		map__foldl(
+			pred(_K::in, Entry::in, S0::in, S::out) is det :- 
+			(
+				( S0 = no -> 
+					S = no
+				;
+					S = fp_entry_stability(Entry)
+				)
+			),
+			T ^ mapping,
+			yes, 
+			yes)
+	;
+		true
+	). 
+
+description(T) = Descr :- 
+	(
+		fixpoint_reached(T)
+	->
+		Descr = "stable"
+	;
+		Descr = "unstable"
+	).
+	
+	
+add(IsLessOrEqualTest, Index, Elem, Tin, Tout) :- 
+	Map = Tin ^ mapping, 
+	map__lookup(Map, Index, Entry),
+	TabledElem = fp_entry_elem(Entry),
+	(
+		IsLessOrEqualTest(Elem, TabledElem)
+	->
+		S = yes
+	;
+		S = no 
+	),
+
+	% whether or not the tabled element is equal to the new element, the
+	% final tabled element will always be set to the new one. This is handy
+	% for performing the following trick: equality can be checked on some
+	% partial piece of the elements (for deciding stability), but some
+	% other part might have changed, a change that should become visible in
+	% the table too.  (in fact this is necessary for the reuse-fixpoint
+	% table where not only the reuses are kept (the abstract substitution),
+	% but also the goal that might have changed. 
+	FinalTabledElem = fp_entry_init(S, Elem),
+	map__det_update(Map, Index, FinalTabledElem, MapOut),
+	Tout = (Tin ^ mapping := MapOut).
+
+get(Index, Elem, Tin, Tout) :-
+	List = Tin ^ keys, 
+	list__member(Index, List), % can fail
+	Mapin = Tin ^ mapping,
+	map__lookup(Mapin, Index, Entry), 
+	Elem = fp_entry_elem(Entry),
+	Mapout = Mapin,
+	Tout = (Tin ^ mapping := Mapout) ^ recursive := yes.
+
+get_final(Index, T) = Elem :- 
+	(
+		TabledElem = get_final_semidet(Index, T)
+	->
+		Elem = TabledElem
+	; 
+		unexpected(this_file, "get_final: key not in map.")
+	).
+
+get_final_semidet(Index, T) = Elem :- 
+	map__search(T ^ mapping, Index, Entry),
+	Elem = fp_entry_elem(Entry). 
+
+:- func this_file = string.
+this_file = "ctgc.fixpoint_table".
Index: compiler/ctgc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ctgc.m,v
retrieving revision 1.1
diff -u -d -r1.1 ctgc.m
--- compiler/ctgc.m	16 Dec 2005 12:17:52 -0000	1.1
+++ compiler/ctgc.m	14 Feb 2006 09:33:32 -0000
@@ -1,11 +1,11 @@
 %-----------------------------------------------------------------------------%
-% Copyright (C) 2005 The University of Melbourne.
+% Copyright (C) 2005-2006 The University of Melbourne.
 % This file may only be copied under the terms of the GNU General
 % Public License - see the file COPYING in the Mercury distribution.
 %-----------------------------------------------------------------------------%
 %
 % File: ctgc.m
-% Main authors: nancy
+% Main author: nancy
 %
 % Package grouping all the modules that are used for compile-time garbage
 % collection. 
@@ -16,6 +16,12 @@
 
 :- interface.
 
+:- import_module parse_tree.
+
+:- include_module datastruct.
+:- include_module fixpoint_table.
+:- include_module selector.
 :- include_module structure_sharing.
+:- include_module util.
 
 :- end_module transform_hlds.ctgc.
Index: compiler/ctgc.selector.m
===================================================================
RCS file: compiler/ctgc.selector.m
diff -N compiler/ctgc.selector.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ compiler/ctgc.selector.m	14 Feb 2006 09:33:33 -0000
@@ -0,0 +1,390 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2005-2006 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: ctgc.selector.m
+% Main authors: nancy
+%
+% Definition of predicates and functions for the manipulation of 
+% selectors. 
+%-----------------------------------------------------------------------------%
+
+:- module transform_hlds.ctgc.selector.
+
+:- interface.
+
+:- import_module hlds.hlds_module.
+:- import_module parse_tree.prog_data.
+
+:- import_module list.
+
+    % Create a selector as either the top selector, a term selector, 
+    % or a type selector.
+    %
+:- func top_selector = selector. 
+:- func init(cons_id, int) = selector.
+:- func init(list(mer_type)) = selector.
+
+    % Perform a termshift operation.
+    %
+:- pred termshift(selector::in, selector::in, selector::out) is det.
+
+    % subsumed_by(ModuleInfo, Selector0, Selector1, Type, Extension). 
+    %
+    % Returns true if Selector0 is subsumed by Selector1. This means that
+    % Selector1 is more general than Selector0, hence, there exists an
+    % extension Ext, such that Selector1.Extension = Selector0. 
+    % Note that the type specifies the type of the term to which the selectors
+    % refer. 
+    %
+:- pred subsumed_by(module_info::in, selector::in, selector::in, 
+	mer_type::in, selector::out) is semidet.
+
+    % Using the type information of the variable to which the given selector
+    % belongs, normalize that selector. 
+    % S2 is the normalized form of S1 iff: 
+    % 	* type of the node selected by S2 = type of the node selected by S1. 
+    % 	* a path of selectors can be constructed which leads from S2 to S1. 
+    %
+:- pred normalize_with_type_information(module_info::in, mer_type::in, 
+	selector::in, selector::out) is det.
+
+    % SubType = type_of_node(ModuleInfo, StartType, Selector).
+    % Determines the type SubType of the node obtained by traversing the type
+    % tree of StartType using the path Selector. 
+    %
+:- func type_of_node(module_info, mer_type, selector) = mer_type.
+
+    % Abbreviate a selector to the type of the node it selects. 
+    %
+:- pred apply_widening(module_info::in, mer_type::in,
+		selector::in, selector::out) is det.
+
+:- implementation.
+
+:- import_module check_hlds.type_util.
+:- import_module libs.compiler_util.
+:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
+
+:- import_module assoc_list.
+:- import_module map.
+:- import_module std_util.
+:- import_module string.
+
+top_selector = [].
+init(Cons, Index) = [termsel(Cons, Index)].
+init(Types) = 
+	list.map(func(T) = US :- US = typesel(T), Types).
+
+termshift(S1, S2, S) :- list.append(S1, S2, S).
+
+subsumed_by(ModuleInfo, S1, S2, MainType, Extension):- 
+    % first make sure that both selectors are in a normalized form.
+    normalize_with_type_information(ModuleInfo, MainType, S1, NormS1), 
+    normalize_with_type_information(ModuleInfo, MainType, S2, NormS2), 
+    subsumed_by_2(ModuleInfo, NormS1, NormS2, MainType, Extension). 
+
+:- pred subsumed_by_2(module_info::in, selector::in, selector::in,
+    mer_type::in, selector::out) is semidet.
+
+subsumed_by_2(ModuleInfo, S1, S2, MainType, Extension):- 
+	(
+		split_upto_type_selector(S2, S2_part1, TS, S2_part2),
+		TS = typesel(SubType)
+	->
+        % step 1: S2_part1.Rest = S1, hence S2_part1 should be more general
+        % than S1. 
+        subsumed_by_2(ModuleInfo, S1, S2_part1, MainType, Rest),
+
+        % step 2: S2_part1.TS.Remainder = S1, hence S2_part1.TS should be more
+        % general than S1. 
+        % i.e.
+        % Check the type-selector part: starting from the type selected by
+        % S2_part1, does the remainder of Rest (the extension of S2_part1 
+        % such that S2_part1.Rest = S1) lead through a node with type
+        % "SubType".
+        %
+        type_on_path(ModuleInfo, type_of_node(ModuleInfo, MainType, S2_part1),
+            SubType, Rest, Remainder),
+
+        % step 3: % S2_part1.TS.S1_part2 should be more general than S1.
+        subsumed_by_2(ModuleInfo, Remainder, S2_part2, SubType, Extension)
+	; 	
+        % If the second selector S2 has no type-
+        % selectors, we have the simple case where S1 can be more
+        % general than S2 if there exists a path "Extension" such that
+        % S1.Extension = S2
+        subsumed_by(S1, S2, Extension)
+	). 
+
+:- pred subsumed_by(selector::in, selector::in, selector::out) is semidet.
+subsumed_by(S1, S2, Extension):-
+	list.append(S2, Extension, S1). 
+
+type_of_node(ModuleInfo, StartType, Selector) = SubType :-
+	(
+		Selector = [ UnitSelector | RestSelector ]
+	->
+		(
+			UnitSelector = termsel(ConsId, Index),
+			SubType0 = select_subtype(ModuleInfo, StartType, ConsId, Index) 
+		; 
+			UnitSelector = typesel(SubType0)
+		),
+		SubType = type_of_node(ModuleInfo, SubType0, RestSelector)
+	;
+		SubType = StartType
+	).
+
+    % SubType = select_subtype(ModuleInfo, Type, ConsID, Position, SubType).
+    % Determine the type of the type node selected from the type tree Type,
+    % selecting the specific constructor (ConsId), at position Position. 
+    % Position counts starting from 1.
+    %
+:- func select_subtype(module_info, mer_type, cons_id, int) = mer_type. 
+
+select_subtype(ModuleInfo, Type, ConsID, Choice) = SubType :- 
+	(
+		get_cons_id_non_existential_arg_types(ModuleInfo, 
+			Type, ConsID, ArgTypes)
+	->
+		(
+			list.index1(ArgTypes, Choice, SubType0)
+		->
+			SubType = SubType0
+		;
+			unexpected(this_file, "get_type_of_node: selection failed.")
+		)
+	;
+		unexpected(this_file, "get_type_of_node: existential type.")
+	).
+
+
+
+    % split_upto_type_selector(Sin, S1, TS, S2): 
+    % This predicate succeeds if there exists a typeselector TS, such that Sin
+    % is equivalent to append(S1, [TS | S2]) and S1 contains no other type
+    % selector. It fails otherwise. 
+:- pred split_upto_type_selector(selector::in, selector::out, 
+		unit_selector::out, selector::out) is semidet.
+
+split_upto_type_selector(Sin, S1, TS, S2):-
+    list.takewhile(is_term_selector, Sin, S1, Remainder), 
+    Remainder = [TS | S2 ].
+
+:- pred is_term_selector(unit_selector::in) is semidet.
+is_term_selector(termsel(_, _)).
+                
+    % type_on_path(ModuleInfo, FromType, ToType, Path, Remainder):
+    % This predicate verifies that the path Path starting from FromType
+    % encounters at least one type node with the type ToType.  Remainder is the
+    % remainder of the Path after stripping it to the last encounter of a node
+    % with "ToType". 
+    % XXX Changed w.r.t. original implementation!
+    % 
+:- pred type_on_path(module_info::in, mer_type::in, mer_type::in, 
+		selector::in, selector::out) is semidet.
+
+type_on_path(ModuleInfo, FromType, ToType, Path, RemainderPath) :-
+    % In checking this, at least one step of the Path must be done. Indeed, if
+    % FromType = ToType, than RemainderPath would be equal to Path, which would
+    % contradict the actual meaning of a type selector: A type-selector is a
+    % shortcut notation for any non-zero (!) selector that selects a node of
+    % the type described by the type-selector. 
+    type_on_path_2(first, ModuleInfo, FromType, 
+        ToType, Path, RemainderPath).
+
+    % In checking whether a type is encountered on a given selector-path 
+    % we check whether the type of a selector is encountered _after_ the first
+    % unit-step on that selector-path. This means that we need to make 
+    % a difference when looking at the first unit-step or any of the subsequent
+    % steps.
+    %
+    % To make the difference during the verification process, the type 'step'
+    % is used. 
+    %
+:- type step 
+    --->    first 
+    ;       subsequent. 
+
+:- pred type_on_path_2(step::in, module_info::in, mer_type::in, mer_type::in, 
+		selector::in, selector::out) is semidet.
+
+type_on_path_2(Step, ModuleInfo, FromType, ToType, Path, RemainderPath) :- 
+	(
+		FromType = ToType, 
+		Step = subsequent	
+	->
+		RemainderPath = Path
+	; 
+		Path = [ UnitSelector | Rest ],
+		(
+			UnitSelector = typesel(SubType),
+			(
+				SubType = ToType
+			->
+                (
+                    % Check if the same type occurs anywhere further on the
+                    % path. 
+                    type_on_path_2(first, ModuleInfo, ToType, ToType, 
+                        Rest, RemainderPath0)
+                -> 
+                    RemainderPath = RemainderPath0
+                ; 
+                    RemainderPath = Rest
+                )
+			;
+                type_on_path_2(subsequent, ModuleInfo, SubType, ToType, 
+                    Rest, RemainderPath)
+			)
+		;
+			UnitSelector = termsel(ConsId, Index), 
+			SubType = select_subtype(ModuleInfo, FromType, ConsId, Index),
+			(
+				SubType = ToType
+			->
+                (
+                    % Check if the same type occurs anywhere further on the
+                    % path. 
+                    type_on_path_2(first, ModuleInfo, ToType, ToType, 
+                        Rest, RemainderPath0)
+                -> 
+                    RemainderPath = RemainderPath0
+                ; 
+				    RemainderPath = Rest
+                )
+			;
+				type_on_path_2(subsequent, ModuleInfo, SubType, ToType, 
+					Rest, RemainderPath)
+			)
+		)
+	).
+
+normalize_with_type_information(ModuleInfo, Type, !Selector) :- 
+	(
+		is_introduced_type_info_type(Type)
+	->
+		true
+	; 
+		branch_map_init(BranchMap0), 
+		branch_map_insert(Type, top_selector, BranchMap0, BranchMap1),
+		normalize_wti(ModuleInfo, Type, BranchMap1, top_selector, !Selector)
+	).
+
+	
+:- pred normalize_wti(module_info::in, mer_type::in, branch_map::in, 
+	selector::in, selector::in, selector::out) is det.
+
+
+normalize_wti(ModuleInfo, VarType, BranchMap0, SelectorAcc0, 
+    !Selector) :- 
+    (
+        !.Selector = [ UnitSelector | SelRest ]
+    ->
+        Class = classify_type(ModuleInfo, VarType),
+        (
+            Class = type_cat_user_ctor
+        ->
+            % If it is either a term-selector of a non existentially typed
+            % functor or a type-selector, construct the branch map and proceed
+            % with normalization. If it is a term-selector of an existentially
+            % typed functor, than normalization stops. 
+            (
+                (
+                    UnitSelector = termsel(ConsId, Index),
+                    get_cons_id_non_existential_arg_types(ModuleInfo, 
+                    VarType, ConsId, ArgTypes),
+                    (
+                        list.index1(ArgTypes, Index, SubType)
+                    ->
+                        CType = SubType
+                    ;
+                        unexpected(this_file, "normalize_wti: " ++ 
+                        "accessing non-existing index.")
+                    )
+                ;
+                    UnitSelector = typesel(CType)
+                )
+            ->  
+                !:Selector = SelRest,
+                (
+                    branch_map_search(BranchMap0, CType,
+                    BranchSelector)
+                ->
+                    normalize_wti(ModuleInfo, CType, 
+                    BranchMap0, BranchSelector, !Selector)
+                ;
+                    termshift(SelectorAcc0, [UnitSelector], 
+                    SelectorAcc1),
+                    branch_map_insert(CType, 
+                    SelectorAcc1, BranchMap0, BranchMap1),
+                    normalize_wti(ModuleInfo, CType, 
+                    BranchMap1, SelectorAcc1, !Selector)
+                )
+            ;
+                % existentially typed functor.
+                append(SelectorAcc0, !Selector)
+            )
+        ;
+            % if it is not a user type, SelRest is empty anyhow, and
+            % normalization stops.
+            % Resulting selector = accumulator.sel0
+            append(SelectorAcc0, !Selector)
+        )
+    ;
+        % SEL0 = []		
+        !:Selector = SelectorAcc0
+    ).
+
+apply_widening(ModuleInfo, MainType, !Selector) :- 
+    (
+        !.Selector = []
+    -> 
+        true
+    ; 
+        UnitSelector = typesel(type_of_node(ModuleInfo, MainType, !.Selector)),
+        !:Selector = [UnitSelector]
+    ).
+
+
+%-----------------------------------------------------------------------------%
+% BRANCH_MAP : copy/pasted from wimvh/bta_reduce.m
+%-----------------------------------------------------------------------------%
+
+:- type branch_map == assoc_list(mer_type, selector).
+
+:- pred branch_map_init(branch_map::out) is det.
+
+:- pred branch_map_insert(mer_type::in, selector::in, branch_map::in, 
+	branch_map::out) is det.
+        
+:- pred branch_map_search(branch_map::in, mer_type::in, 
+	selector::out) is semidet.
+
+branch_map_init([]).
+
+branch_map_insert(Type, SelPart, Map1, [(Type - SelPart) | Map1]).
+
+branch_map_search([ (T1 - S1) | Ms ], T2, S):-
+    map.init(Empty),
+    % The two types are considered equal if they unify under an
+    % empty substitution
+    (
+        type_unify(T1, T2, [], Empty, Subst), 
+        map.is_empty(Subst)
+	->
+        S = S1
+    ;
+        branch_map_search(Ms, T2, S)
+    ).
+
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string. 
+this_file = "ctgc.selector.m".
Index: compiler/ctgc.util.m
===================================================================
RCS file: compiler/ctgc.util.m
diff -N compiler/ctgc.util.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ compiler/ctgc.util.m	14 Feb 2006 09:33:33 -0000
@@ -0,0 +1,65 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2006 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: ctgc.util.m
+% Main authors: nancy
+%
+% Utility operations for the CTGC-system.
+%
+%-----------------------------------------------------------------------------%
+
+:- module transform_hlds.ctgc.util.
+
+:- interface.
+
+:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_pred.
+
+:- import_module list.
+
+	% Check if some of the predicates are "special" predicates (as in
+	% "special_pred_map" known from module_info) or not defined in the
+	% current module, as these predicates are not analysed by the CTGC
+	% system.
+	%
+:- pred preds_requiring_no_analysis(module_info::in, 
+	list(pred_proc_id)::in) is semidet.
+
+:- implementation.
+
+:- import_module bool.
+:- import_module map.
+
+preds_requiring_no_analysis(ModuleInfo, PredProcIds) :- 
+	module_info_get_special_pred_map(ModuleInfo, SpecialPredMap), 
+	map.values(SpecialPredMap, SpecialPreds), 
+	(
+
+		list.filter(pred_id_in(SpecialPreds), PredProcIds,
+				SpecialPredProcs),
+		SpecialPredProcs = [_|_]
+
+	; 
+		% or some of the predicates are not defined in this
+		% module. 
+		list.filter(not_defined_in_this_module(ModuleInfo), 	
+			PredProcIds, FilteredPredProcIds), 
+		FilteredPredProcIds = [_|_]
+	).
+
+:- pred pred_id_in(list(pred_id)::in, pred_proc_id::in) is semidet.
+pred_id_in(PredIds, PredProcId):-
+	PredProcId = proc(PredId, _),
+	list.member(PredId, PredIds). 
+
+:- pred not_defined_in_this_module(module_info::in, 
+	pred_proc_id::in) is semidet.
+not_defined_in_this_module(ModuleInfo, proc(PredId, _)):-
+	module_info_pred_info(ModuleInfo, PredId, PredInfo),
+	pred_info_import_status(PredInfo, Status),
+	status_defined_in_this_module(Status, no).
+
+:- end_module transform_hlds.ctgc.util.
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.255
diff -u -d -r1.255 handle_options.m
--- compiler/handle_options.m	13 Feb 2006 07:57:21 -0000	1.255
+++ compiler/handle_options.m	14 Feb 2006 09:33:36 -0000
@@ -729,6 +729,8 @@
         option_implies(check_termination2, termination2, bool(yes), !Globals),
         option_implies(check_termination2, warn_missing_trans_opt_files,
             bool(yes), !Globals),
+        option_implies(structure_sharing_analysis, 
+            transitive_optimization, bool(yes), !Globals), 
         option_implies(make_transitive_opt_interface, transitive_optimization,
             bool(yes), !Globals),
         option_implies(transitive_optimization, intermodule_optimization,
@@ -2339,9 +2341,9 @@
 
 :- pred convert_dump_alias(string::in, string::out) is semidet.
 
-convert_dump_alias("ALL", "abcdfgilmnprstuvBCDIMPTU").
+convert_dump_alias("ALL", "abcdfgilmnprstuvBCDIMPSTU").
 convert_dump_alias("allD", "abcdfgilmnprstuvBCDMPT").
-convert_dump_alias("all", "abcdfgilmnprstuvBCMPT").
+convert_dump_alias("all", "abcdfgilmnprstuvBCMPST").
 convert_dump_alias("most", "bcdfgilmnprstuvP").
 convert_dump_alias("trans", "bcdglmnstuv").
 convert_dump_alias("codegen", "dfnprsu").
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.377
diff -u -d -r1.377 hlds_out.m
--- compiler/hlds_out.m	28 Nov 2005 04:11:42 -0000	1.377
+++ compiler/hlds_out.m	14 Feb 2006 09:33:42 -0000
@@ -269,6 +269,7 @@
 :- import_module libs.globals.
 :- import_module libs.options.
 :- import_module parse_tree.mercury_to_mercury.
+:- import_module parse_tree.prog_ctgc.
 :- import_module parse_tree.prog_io_util.
 :- import_module parse_tree.prog_mode.
 :- import_module parse_tree.prog_out.
@@ -3633,6 +3634,7 @@
     proc_info_context(Proc, ModeContext),
     proc_info_get_maybe_arg_size_info(Proc, MaybeArgSize),
     proc_info_get_maybe_termination_info(Proc, MaybeTermination),
+    proc_info_get_structure_sharing(Proc, MaybeStructureSharing), 
     proc_info_rtti_varmaps(Proc, RttiVarMaps),
     proc_info_eval_method(Proc, EvalMethod),
     proc_info_is_address_taken(Proc, IsAddressTaken),
@@ -3666,6 +3668,16 @@
         io__write_string("% Termination properties: ", !IO),
         write_maybe_termination_info(MaybeTermination, yes, !IO),
         io__nl(!IO)
+    ;
+        true
+    ),
+
+        % Dump structure sharing information.
+    ( string__contains_char(Verbose, 'S') ->
+        write_indent(Indent, !IO),
+        io__write_string("% Structure sharing: \n", !IO),
+        dump_maybe_structure_sharing_domain(VarSet, TVarSet, 
+            MaybeStructureSharing, !IO)
     ;
         true
     ),
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.187
diff -u -d -r1.187 hlds_pred.m
--- compiler/hlds_pred.m	7 Dec 2005 16:07:01 -0000	1.187
+++ compiler/hlds_pred.m	14 Feb 2006 09:33:48 -0000
@@ -2673,6 +2673,12 @@
 :- pred proc_info_set_termination2_info(termination2_info::in,
     proc_info::in, proc_info::out) is det.
 
+:- pred proc_info_get_structure_sharing(proc_info::in,
+    maybe(structure_sharing_domain)::out) is det.
+
+:- pred proc_info_set_structure_sharing(structure_sharing_domain::in, 
+    proc_info::in, proc_info::out) is det.
+
 :- pred proc_info_head_modes_constraint(proc_info::in, mode_constraint::out)
     is det.
 
@@ -2965,13 +2971,17 @@
 
         maybe_deep_profile_proc_info :: maybe(deep_profile_proc_info),
 
-        maybe_untuple_info          :: maybe(untuple_proc_info)
+        maybe_untuple_info          :: maybe(untuple_proc_info), 
                                     % If set, it means this procedure was
                                     % created from another procedure by the
                                     % untupling transformation. This slot
                                     % records which of the procedure's
                                     % arguments were derived from which
                                     % arguments in the original procedure.
+                                    
+        maybe_structure_sharing     :: maybe(structure_sharing_domain)
+                                    % Structure sharing information as obtained
+                                    % by the structure sharing analysis.
     ).
 
     % Some parts of the procedure aren't known yet. We initialize
@@ -3000,7 +3010,7 @@
         DeclaredModes, Modes, no, MaybeArgLives, MaybeDet, InferredDet,
         ClauseBody, CanProcess, ModeErrors, RttiVarMaps, eval_normal,
         proc_sub_info(no, no, Term2Info, IsAddressTaken, StackSlots,
-        ArgInfo, InitialLiveness, no, no, no, no, no)).
+        ArgInfo, InitialLiveness, no, no, no, no, no, no)).
 
 proc_info_set(Context, BodyVarSet, BodyTypes, HeadVars, InstVarSet, HeadModes,
         HeadLives, DeclaredDetism, InferredDetism, Goal, CanProcess,
@@ -3008,7 +3018,7 @@
         IsAddressTaken, StackSlots, ArgInfo, Liveness, ProcInfo) :-
     ModeErrors = [],
     ProcSubInfo = proc_sub_info(ArgSizes, Termination, Termination2,
-        IsAddressTaken, StackSlots, ArgInfo, Liveness, no, no, no, no, no),
+        IsAddressTaken, StackSlots, ArgInfo, Liveness, no, no, no, no, no, no),
     ProcInfo = proc_info(Context, BodyVarSet, BodyTypes, HeadVars,
         InstVarSet, no, HeadModes, no, HeadLives,
         DeclaredDetism, InferredDetism, Goal, CanProcess, ModeErrors,
@@ -3030,7 +3040,7 @@
     ModeErrors = [],
     Term2Info = term_constr_main__term2_info_init,
     ProcSubInfo = proc_sub_info(no, no, Term2Info, IsAddressTaken,
-        StackSlots, no, Liveness, no, no, no, no, no),
+        StackSlots, no, Liveness, no, no, no, no, no, no),
     ProcInfo = proc_info(Context, VarSet, VarTypes, HeadVars,
         InstVarSet, no, HeadModes, no, MaybeHeadLives,
         MaybeDeclaredDetism, Detism, Goal, yes, ModeErrors,
@@ -3191,6 +3201,13 @@
 proc_info_set_termination2_info(Termination2Info, !ProcInfo) :-
     !:ProcInfo = !.ProcInfo ^ proc_sub_info ^ termination2 :=
         Termination2Info.
+
+proc_info_get_structure_sharing(ProcInfo, MaybeSharing) :-
+    MaybeSharing = ProcInfo ^ proc_sub_info ^ maybe_structure_sharing.
+
+proc_info_set_structure_sharing(Sharing, !ProcInfo) :- 
+    !:ProcInfo = !.ProcInfo ^ proc_sub_info ^ maybe_structure_sharing :=
+        yes(Sharing).
 
 proc_info_get_typeinfo_vars(Vars, VarTypes, RttiVarMaps, TypeInfoVars) :-
     TVarMap = RttiVarMaps ^ ti_varmap,
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds_passes.m,v
retrieving revision 1.24
diff -u -d -r1.24 make_hlds_passes.m
--- compiler/make_hlds_passes.m	28 Nov 2005 04:11:45 -0000	1.24
+++ compiler/make_hlds_passes.m	14 Feb 2006 09:33:51 -0000
@@ -921,6 +921,12 @@
             MaybeSuccessArgSizeInfo, MaybeFailureArgSizeInfo,
             MaybeTerminationInfo, Context, !ModuleInfo, !IO)
     ;
+        Pragma = structure_sharing(PredOrFunc, SymName, ModeList,
+            HeadVars, Types, SharingDomain)
+    -> 
+        add_pragma_structure_sharing(PredOrFunc, SymName, ModeList,
+            HeadVars, Types, SharingDomain, Context, !ModuleInfo, !IO)
+    ;
         Pragma = reserve_tag(TypeName, TypeArity)
     ->
         add_pragma_reserve_tag(TypeName, TypeArity, !.Status,
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.376
diff -u -d -r1.376 mercury_compile.m
--- compiler/mercury_compile.m	13 Feb 2006 03:47:42 -0000	1.376
+++ compiler/mercury_compile.m	14 Feb 2006 09:33:58 -0000
@@ -2056,6 +2056,8 @@
     globals__lookup_bool_option(Globals, statistics, Stats),
     globals__lookup_bool_option(Globals, termination, Termination),
     globals__lookup_bool_option(Globals, termination2, Termination2),
+    globals__lookup_bool_option(Globals, structure_sharing_analysis, 
+        SharingAnalysis), 
     globals__lookup_bool_option(Globals, analyse_exceptions,
         ExceptionAnalysis),
     globals__lookup_bool_option(Globals, analyse_closures,
@@ -2076,6 +2078,7 @@
             ; Termination2 = yes
             ; ExceptionAnalysis = yes
             ; TrailingAnalysis = yes
+            ; SharingAnalysis = yes
             )
         ->
             frontend_pass_by_phases(!HLDS, FoundModeError, !DumpInfo, !IO),
@@ -2116,6 +2119,13 @@
                     Termination2 = no
                 ),
                 (
+                    SharingAnalysis = yes, 
+                    maybe_structure_sharing_analysis(Verbose, Stats,
+                        !HLDS, !IO)
+                ;
+                    SharingAnalysis = no
+                ),
+                (
                     TrailingAnalysis = yes,
                     maybe_analyse_trail_usage(Verbose, Stats, !HLDS, !IO)
                 ;
@@ -2186,6 +2196,8 @@
     maybe_dump_hlds(!.HLDS, 121, "termination_2", !DumpInfo, !IO),
     maybe_analyse_trail_usage(Verbose, Stats, !HLDS, !IO),
     maybe_dump_hlds(!.HLDS, 167, "trail_usage", !DumpInfo, !IO),
+    maybe_structure_sharing_analysis(Verbose, Stats, !HLDS, !IO),
+    maybe_dump_hlds(!.HLDS, 193, "structure_sharing", !DumpInfo, !IO),
     trans_opt__write_optfile(!.HLDS, !IO).
 
 :- pred output_analysis_file(module_name::in,
@@ -2410,7 +2422,7 @@
     maybe_eliminate_dead_procs(Verbose, Stats, !HLDS, !IO),
     maybe_dump_hlds(!.HLDS, 192, "dead_procs", !DumpInfo, !IO),
 
-    maybe_data_structure_sharing_analysis(Verbose, Stats, !HLDS, !IO), 
+    maybe_structure_sharing_analysis(Verbose, Stats, !HLDS, !IO), 
     maybe_dump_hlds(!.HLDS, 193, "structure_sharing", !DumpInfo, !IO), 
     
     % If we are compiling in a deep profiling grade then now rerun simplify.
@@ -3742,18 +3754,18 @@
         Dead = no
     ).
 
-:- pred maybe_data_structure_sharing_analysis(bool::in, bool::in,
+:- pred maybe_structure_sharing_analysis(bool::in, bool::in,
     module_info::in, module_info::out, io::di, io::uo) is det.
 
-maybe_data_structure_sharing_analysis(Verbose, Stats, !HLDS, !IO) :- 
-    globals__io_lookup_bool_option(data_structure_sharing_analysis, 
+maybe_structure_sharing_analysis(Verbose, Stats, !HLDS, !IO) :- 
+    globals__io_lookup_bool_option(structure_sharing_analysis, 
         Sharing, !IO), 
     (
         Sharing = yes, 
-        maybe_write_string(Verbose, "% Data structure sharing analysis...\n",
+        maybe_write_string(Verbose, "% Structure sharing analysis...\n",
             !IO), 
         maybe_flush_output(Verbose, !IO), 
-        data_structure_sharing_analysis(!HLDS, !IO), 
+        structure_sharing_analysis(!HLDS, _SharingTable, !IO), 
         maybe_write_string(Verbose, "% done.\n", !IO),
         maybe_report_stats(Stats, !IO)
     ;
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.279
diff -u -d -r1.279 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m	10 Feb 2006 04:59:58 -0000	1.279
+++ compiler/mercury_to_mercury.m	14 Feb 2006 09:34:04 -0000
@@ -314,6 +314,11 @@
 	maybe(generic_arg_size_info(T))::in,
 	maybe(generic_termination_info(S, T))::in, io::di, io::uo) is det.
 
+:- pred write_pragma_structure_sharing_info(pred_or_func::in, sym_name::in,
+    list(mer_mode)::in, prog_context::in, prog_vars::in, 
+    maybe(prog_varset)::in, list(mer_type)::in, maybe(tvarset)::in, 
+    maybe(structure_sharing_domain)::in, io::di, io::uo) is det.
+
     % Write the given arg size info. Verbose if the second arg is yes.
     %
 :- pred write_maybe_arg_size_info(maybe(generic_arg_size_info(T))::in,
@@ -384,6 +389,7 @@
 :- import_module libs.options.
 :- import_module libs.rat.
 :- import_module parse_tree.error_util.
+:- import_module parse_tree.prog_ctgc.
 :- import_module parse_tree.prog_io_util.
 :- import_module parse_tree.prog_out.
 :- import_module parse_tree.prog_util.
@@ -392,6 +398,7 @@
 :- import_module assoc_list.
 :- import_module int.
 :- import_module lexer.
+:- import_module map.
 :- import_module ops.
 :- import_module set.
 :- import_module string.
@@ -683,6 +690,11 @@
         mercury_output_pragma_decl(Pred, Arity, predicate,
             "check_termination", no, !IO)
     ;
+        Pragma = structure_sharing(PredOrFunc, PredName, ModesList, HeadVars,
+            Types, MaybeStructureSharing), 
+        write_pragma_structure_sharing_info(PredOrFunc, PredName, ModesList, 
+            Context, HeadVars, no, Types, no, MaybeStructureSharing, !IO)
+    ;
         Pragma = mode_check_clauses(Pred, Arity),
         mercury_output_pragma_decl(Pred, Arity, predicate,
             "mode_check_clauses", no, !IO)
@@ -4335,6 +4347,70 @@
 	),
 	io.write_string(TerminationStr, !IO).	
 
+%-----------------------------------------------------------------------------%
+
+write_pragma_structure_sharing_info(PredOrFunc, SymName, Modes, Context, 
+        HeadVars, MaybeVarSet, HeadVarTypes, MaybeTypeVarSet, 
+        MaybeSharingAs, !IO) :- 
+    io__write_string(":- pragma structure_sharing(", !IO), 
+    varset__init(InitVarSet), 
+    (
+        MaybeVarSet = yes(VarSet)
+    ; 
+        MaybeVarSet = no, 
+        varset__init(VarSet)
+    ),
+    (
+        MaybeTypeVarSet = yes(TypeVarSet)
+    ;
+        MaybeTypeVarSet = no, 
+        varset__init(TypeVarSet)
+    ),
+
+    (
+        PredOrFunc = predicate, 
+        mercury_output_pred_mode_subdecl(InitVarSet, SymName,
+            Modes, no, Context, !IO)
+    ;
+        PredOrFunc = function,
+        pred_args_to_func_args(Modes, FuncModeList, RetMode),
+        mercury_output_func_mode_subdecl(InitVarSet, SymName,
+            FuncModeList, RetMode, no, Context, !IO)
+    ),
+    % write headvars and types:
+    io__write_string(", ", !IO), 
+    write_vars_and_types(HeadVars, VarSet, HeadVarTypes, TypeVarSet, !IO), 
+    % write structure sharing information. 
+    io__write_string(", ", !IO), 
+    prog_ctgc.print_interface_structure_sharing_domain(VarSet, TypeVarSet, 
+        MaybeSharingAs, !IO),
+    io__write_string(").\n", !IO).
+
+:- pred write_vars_and_types(prog_vars::in, prog_varset::in, 
+    list(mer_type)::in, tvarset::in, io::di, io::uo) is det.
+
+write_vars_and_types(HeadVars, VarSet, HeadVarTypes, TypeVarSet, !IO) :- 
+    (
+        HeadVars = []
+    -> 
+        io__write_string("vars, types", !IO)
+    ;
+        io__write_string("vars(", !IO), 
+        mercury_output_vars(HeadVars, VarSet, no, !IO), 
+        io__write_string("), ", !IO),
+
+        io__write_string("types(", !IO), 
+        io__write_list(HeadVarTypes, ",", mercury_output_type(TypeVarSet, no),
+            !IO), 
+        io__write_string(")", !IO)
+    ).
+
+:- pred write_type_of_var(vartypes::in, tvarset::in, prog_var::in, io::di, 
+    io::uo) is det.
+write_type_of_var(VarTypes, TypeVarSet, Var, !IO):- 
+    map.lookup(VarTypes, Var, VarType), 
+    mercury_output_type(TypeVarSet, no, VarType, !IO). 
+    
 %---------------------------------------------------------------------------%
 
 :- func this_file = string.
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.123
diff -u -d -r1.123 module_qual.m
--- compiler/module_qual.m	16 Jan 2006 03:08:13 -0000	1.123
+++ compiler/module_qual.m	14 Feb 2006 09:34:07 -0000
@@ -1113,6 +1113,11 @@
         termination_info(PredOrFunc, SymName, ModeList, Args, Term),
         !Info, !IO) :-
     qualify_mode_list(ModeList0, ModeList, !Info, !IO).
+qualify_pragma(structure_sharing(PredOrFunc, SymName, ModeList0, Vars, Types,
+        Sharing),
+        structure_sharing(PredOrFunc, SymName, ModeList, Vars, Types, Sharing),
+        !Info, !IO) :-
+    qualify_mode_list(ModeList0, ModeList, !Info, !IO).
 qualify_pragma(termination2_info(PredOrFunc, SymName, ModeList0,
             SuccessArgs, FailureArgs, Term), 
         termination2_info(PredOrFunc, SymName, ModeList,
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.373
diff -u -d -r1.373 modules.m
--- compiler/modules.m	13 Feb 2006 03:47:43 -0000	1.373
+++ compiler/modules.m	14 Feb 2006 09:34:20 -0000
@@ -2123,6 +2123,7 @@
 pragma_allowed_in_interface(terminates(_, _), yes).
 pragma_allowed_in_interface(does_not_terminate(_, _), yes).
 pragma_allowed_in_interface(check_termination(_, _), yes).
+pragma_allowed_in_interface(structure_sharing(_, _, _, _, _, _), yes).
     % `aditi', `base_relation', `index' and `owner' pragmas must be in the
     % interface for exported preds. This is checked in make_hlds.m.
 pragma_allowed_in_interface(aditi(_, _), yes).
@@ -7723,6 +7724,7 @@
     ; Pragma = terminates(_, _), Reorderable = yes
     ; Pragma = termination2_info(_, _, _, _, _, _), Reorderable = no
     ; Pragma = termination_info(_, _, _, _, _), Reorderable = yes
+    ; Pragma = structure_sharing(_, _, _, _, _, _), Reorderable = yes
     ; Pragma = type_spec(_, _, _, _, _, _, _, _), Reorderable = yes
     ; Pragma = unused_args(_, _, _, _, _), Reorderable = yes
     ).
@@ -7811,6 +7813,7 @@
     ; Pragma = terminates(_, _), Reorderable = yes
     ; Pragma = termination2_info( _, _, _, _, _, _), Reorderable = no
     ; Pragma = termination_info(_, _, _, _, _), Reorderable = yes
+    ; Pragma = structure_sharing(_, _, _, _, _, _), Reorderable = yes
     ; Pragma = trailing_info(_, _, _, _, _), Reorderable = yes
     ; Pragma = type_spec(_, _, _, _, _, _, _, _), Reorderable = yes
     ; Pragma = unused_args(_, _, _, _, _), Reorderable = yes
