Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.498
diff -u -d -r1.498 options.m
--- compiler/options.m	13 Feb 2006 07:57:22 -0000	1.498
+++ compiler/options.m	14 Feb 2006 09:34:28 -0000
@@ -518,7 +518,6 @@
     ;       follow_code
     ;       prev_code
     ;       optimize_dead_procs
-    ;       data_structure_sharing_analysis
     ;       deforestation
     ;       deforestation_depth_limit
     ;       deforestation_cost_factor
@@ -532,6 +531,10 @@
     ;       termination_error_limit
     ;       termination_path_limit
 
+    % Stuff for the CTGC system (structure sharing / structure reuse).
+    ;       structure_sharing_analysis
+    ;           structure_sharing_widening
+
     % Stuff for the new termination analyser.
     ;       termination2
     ;          check_termination2
@@ -1158,6 +1161,8 @@
     analysis_repeat                     -   int(0),
     check_termination                   -   bool(no),
     verbose_check_termination           -   bool(no),
+    structure_sharing_analysis          -   bool(no), 
+    structure_sharing_widening          -   int(0),
     termination                         -   bool(no),
     termination_single_args             -   int(0),
     termination_norm                    -   string("total"),
@@ -1245,7 +1250,6 @@
     optimize_constructor_last_call_accumulator -    bool(no),
     optimize_constructor_last_call      -   bool(no),
     optimize_dead_procs                 -   bool(no),
-    data_structure_sharing_analysis     -   bool(no),
     deforestation                       -   bool(no),
     deforestation_depth_limit           -   int(4),
     deforestation_cost_factor           -   int(1000),
@@ -1946,8 +1950,6 @@
                     optimize_constructor_last_call).
 long_option("optimize-dead-procs",  optimize_dead_procs).
 long_option("optimise-dead-procs",  optimize_dead_procs).
-long_option("data-structure-sharing-analysis",
-    data_structure_sharing_analysis).
 long_option("deforestation",        deforestation).
 long_option("deforestation-depth-limit",    deforestation_depth_limit).
 long_option("deforestation-cost-factor",    deforestation_cost_factor).
@@ -2002,6 +2004,10 @@
 long_option("tuple-costs-ratio",    tuple_costs_ratio).
 long_option("tuple-min-args",       tuple_min_args).
 
+% CTGC related options.
+long_option("structure-sharing",    structure_sharing_analysis).
+long_option("structure-sharing-widening", structure_sharing_widening).
+
 % HLDS->LLDS optimizations
 long_option("smart-indexing",       smart_indexing).
 long_option("dense-switch-req-density", dense_switch_req_density).
@@ -2738,6 +2744,7 @@
     options_help_aux_output,
     options_help_semantics,
     options_help_termination,
+    options_help_ctgc,
     options_help_compilation_model,
     options_help_code_generation,
     options_help_optimization,
@@ -3236,6 +3243,20 @@
         "\tPerform at most <n> passes of mode inference (default: 30)."
     ]).
 
+
+:- pred options_help_ctgc(io::di, io::uo) is det.
+
+options_help_ctgc -->
+    io__write_string("\nCompile Time Garbage Collection Options:\n"),
+    write_tabbed_lines([
+        "--structure-sharing",
+        "\tPerform structure sharing analysis for all encountered",
+        "\tpredicates.", 
+        "--structure-sharing-widening <n>",
+        "\tPerform widening when the set of structure sharing pairs becomes",
+        "\tlarger than <n>. When n=0, widening is not enabled.",
+        "\t(default: 0)."
+    ]).
 
 :- pred options_help_termination(io::di, io::uo) is det.
 
Index: compiler/parse_tree.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/parse_tree.m,v
retrieving revision 1.14
diff -u -d -r1.14 parse_tree.m
--- compiler/parse_tree.m	23 Nov 2005 04:44:06 -0000	1.14
+++ compiler/parse_tree.m	14 Feb 2006 09:34:28 -0000
@@ -28,12 +28,15 @@
 :- include_module prog_data.
 
 % The parser.
-:- include_module prog_io.
+:- include_module prog_io. 
    :- include_module prog_io_dcg.
    :- include_module prog_io_goal.
    :- include_module prog_io_pragma.
    :- include_module prog_io_typeclass.
    :- include_module prog_io_util.
+
+% Parser/pretty-printer/utility routines for the ctgc related types.
+:- include_module prog_ctgc.
 
 % Pretty-printers.
 :- include_module mercury_to_mercury.
Index: compiler/prog_ctgc.m
===================================================================
RCS file: compiler/prog_ctgc.m
diff -N compiler/prog_ctgc.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ compiler/prog_ctgc.m	14 Feb 2006 09:34:28 -0000
@@ -0,0 +1,447 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% 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: prog_ctgc.m
+% Main author: nancy
+%
+% Utility operations (parsing, printing, renaming) for compile-time garbage
+% collection related information, i.e. structure sharing and structure reuse. 
+%
+%-----------------------------------------------------------------------------%
+
+:- module parse_tree.prog_ctgc.
+
+:- interface.
+
+:- import_module parse_tree.prog_data.
+
+:- import_module bool.
+:- import_module int.
+:- import_module io. 
+:- import_module map.
+:- import_module std_util.
+:- import_module term.
+
+%-----------------------------------------------------------------------------%
+% Parsing  routines
+%-----------------------------------------------------------------------------%
+
+:- func parse_unit_selector(term(T)) = unit_selector. 
+:- func parse_selector(term(T)) = selector.
+:- func parse_datastruct(term(T)) = datastruct.
+:- func parse_structure_sharing_pair(term(T)) = structure_sharing_pair.
+:- func parse_structure_sharing(term(T)) = structure_sharing.
+:- func parse_structure_sharing_domain(term(T)) = structure_sharing_domain.
+
+%-----------------------------------------------------------------------------%
+% Printing routines
+%-----------------------------------------------------------------------------%
+
+:- pred print_selector(tvarset::in, selector::in, io__state::di, 
+    io__state::uo) is det.
+:- pred print_datastruct(prog_varset::in, tvarset::in, datastruct::in, 
+    io__state::di, io__state::uo) is det.
+:- pred print_structure_sharing_pair(prog_varset::in, tvarset::in, 
+    structure_sharing_pair::in, io__state::di, io__state::uo) is det.
+    
+    % Print list of structure sharing pairs.
+    %
+    % print_structure_sharing(Varset, TVarset, MaybeThreshold, 
+    %   StartingString, Separator, EndingString, SharingPairs, !IO):
+    % 
+    % Print the list of sharing pairs using StartString to precede the
+    % list, using EndString to end the list, using Separator to separate
+    % each of the sharing pairs occuring in the list. If a threshold, say
+    % N, is given, then only the first N pairs are printed (and "..." 
+    % is shown if there are more than N pairs). 
+    %
+:- pred print_structure_sharing(prog_varset::in, tvarset::in, 
+    maybe(int)::in, string::in, string::in, string::in, 
+    structure_sharing::in, io__state::di, io__state::uo) is det.
+
+    % Print complete list of structure sharing pairs as a list (using "[",
+    % ",", and "]"). This can later be parsed automatically. 
+    %
+:- pred print_structure_sharing(prog_varset::in, tvarset::in, 
+    structure_sharing::in, io__state::di, io__state::uo) is det.
+
+    % Print structure sharing domain. 
+    %
+    % print_structure_sharing_domain(P, T, VerboseTop, MaybeThreshold, 
+    %   Sharing, !IO): 
+    % If VerboseTop = yes, then the full list of reasons why sharing is 
+    % top is printed as "top([ ... Messages ... ])". If VerboseTop = no,
+    % then top is printed as "top".
+    % If a threshold is given, say N, then only the first N structure 
+    % sharing pairs are printed. 
+    %
+    % The output can later be parsed again only if VerboseTop = no and
+    % MaybeThreshold = no. 
+    %
+:- pred print_structure_sharing_domain(prog_varset::in, tvarset::in, bool::in,
+    maybe(int)::in, structure_sharing_domain::in, io__state::di,
+    io__state::uo) is det.
+
+    % Print the available structure sharing information as a
+    % mercury-comment (used in the hlds-dump).
+    %
+:- pred dump_maybe_structure_sharing_domain(prog_varset::in, tvarset::in, 
+    maybe(structure_sharing_domain)::in, io__state::di, 
+    io__state::uo) is det.
+
+:- pred print_interface_structure_sharing_domain(prog_varset::in, 
+    tvarset::in, maybe(structure_sharing_domain)::in, io__state::di, 
+    io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+% Renaming operations.
+%-----------------------------------------------------------------------------%
+
+:- pred rename_unit_selector(tsubst::in, unit_selector::in, 
+    unit_selector::out) is det.
+:- pred rename_selector(tsubst::in, selector::in, selector::out) is det.
+:- pred rename_datastruct(map(prog_var, prog_var)::in, tsubst::in,
+    datastruct::in, datastruct::out) is det.
+:- func rename_datastruct(map(prog_var, prog_var), tsubst, datastruct) 
+    = datastruct.
+:- pred rename_structure_sharing_pair(map(prog_var, prog_var)::in, 
+    tsubst::in, structure_sharing_pair::in, structure_sharing_pair::out)
+    is det.
+:- pred rename_structure_sharing(map(prog_var, prog_var)::in, 
+    tsubst::in, structure_sharing::in, structure_sharing::out) is det.
+:- pred rename_structure_sharing_domain(map(prog_var, prog_var)::in, 
+    tsubst::in, structure_sharing_domain::in, 
+    structure_sharing_domain::out) is det.
+
+%-----------------------------------------------------------------------------%
+:- implementation. 
+
+:- import_module libs.compiler_util.
+:- import_module parse_tree.mercury_to_mercury.
+:- import_module parse_tree.prog_io.
+:- import_module parse_tree.prog_io_util.
+:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_type_subst.
+:- import_module parse_tree.prog_util.
+
+:- import_module list.
+:- import_module string.
+:- import_module varset.
+
+%-----------------------------------------------------------------------------%
+% Implementation: Parsing routines
+%-----------------------------------------------------------------------------%
+
+parse_unit_selector(Term) = UnitSelector :- 
+    ( 
+        Term = term__functor(term__atom(Cons), Args, _)
+    ->
+        (
+            Cons = "sel",
+            Args = [ ConsTerm, ArityTerm, PosTerm ]
+        ->
+            ( 
+                prog_io__sym_name_and_args(ConsTerm, ConsIDName, []),
+                ArityTerm = term__functor(term__integer(Arity), _, _),
+                PosTerm = term__functor(term__integer(Pos), _, _)
+            ->
+                ConsID = cons(ConsIDName, Arity),
+                UnitSelector = termsel(ConsID, Pos)
+            ;
+                ConsTerm = term__functor(term__integer(X), _, _)
+            ->
+                ConsID = int_const(X), 
+                UnitSelector = termsel(ConsID, 0)
+            ;
+                ConsTerm = term__functor(term__float(X), _, _)
+            ->
+                ConsID = float_const(X),
+                UnitSelector = termsel(ConsID, 0)
+            ;
+                ConsTerm = term__functor(term__string(S), _, _)
+            ->
+                ConsID = string_const(S),
+                UnitSelector = termsel(ConsID, 0)
+            ;
+                unexpected(this_file, "parse_unit_selector: " ++ 
+                    "unknown cons_id in unit selector")
+            )
+        ; 
+     
+            Cons = "typesel",
+            Args = [ TypeSelectorTerm ]
+        ->
+            
+            parse_type(term__coerce(TypeSelectorTerm), MaybeTypeSelector), 
+            (
+                MaybeTypeSelector = ok(TypeSelector),
+                UnitSelector = typesel(TypeSelector)
+            ;
+                MaybeTypeSelector = error(Msg, _),
+                unexpected(this_file, "parse_unit_selector: " ++ 
+                    "error parsing type selector (" ++ Msg ++ ").")
+            )
+        ;
+            unexpected(this_file, "parse_unit_selector: " ++ 
+                "selector is neither sel/3 nor typesel/1.")
+      )
+   ;
+      unexpected(this_file, "parse_unit_selector: term not a functor")
+   ).
+
+
+parse_selector(Term) = Selector :- 
+    (
+        Term = term__functor(term__atom(Cons), Args, _)
+    ->
+        (
+            Cons = "[|]",
+            Args = [ First , Rest ]
+        ->
+            Selector = [ parse_unit_selector(First) | 
+                parse_selector(Rest) ]
+        ;
+            Selector = []
+        )
+    ;
+        unexpected(this_file, "parse_selector: term not a functor")
+    ).
+
+parse_datastruct(Term) = Datastruct :- 
+    (
+        Term = term__functor(term__atom(Cons), Args, _),
+        Cons = "cel",
+        Args = [ VarTerm, SelectorTerm ],
+        VarTerm = term__variable(Var)
+    ->
+        Datastruct = selected_cel(term__coerce_var(Var), 
+            parse_selector(SelectorTerm))
+    ;
+        unexpected(this_file, "parse_datastruct: error while parsing" ++
+            " datastruct.")
+    ).
+
+parse_structure_sharing_pair(Term) = SharingPair :- 
+    (
+        Term = term__functor(term__atom(Cons), Args, _),
+        Cons = "pair",
+        Args = [ First, Second ]
+    -> 
+        SharingPair = parse_datastruct(First) - parse_datastruct(Second)
+    ;
+        unexpected(this_file, "Error while parsing structure sharing pair.")
+    ). 
+
+parse_structure_sharing(Term) = SharingPairs :- 
+    (
+        Term = term__functor(term__atom(Cons), Args, _),
+        (
+            Cons = "[|]",
+            Args = [ SharingPairTerm, Rest],
+            SharingPairs0 = [ parse_structure_sharing_pair(SharingPairTerm) | 
+            parse_structure_sharing(Rest) ]
+        ;
+            Cons = "[]",
+            SharingPairs0 = []
+        )
+        -> 
+            SharingPairs = SharingPairs0
+        ;
+            unexpected(this_file, "Error while parsing list of structure " ++ 
+                "sharing pairs.")
+    ).
+
+parse_structure_sharing_domain(Term) = SharingAs :- 
+    (
+        Term = term__functor(term__atom(Cons), _, Context),
+        (
+            Cons = "[|]",
+            SharingAs0 = real(parse_structure_sharing(Term))
+        ;
+            Cons = "bottom",
+            SharingAs0 = bottom
+        ; 
+            Cons = "top",
+            context_to_string(Context, ContextMsg), 
+            SharingAs0 = top([ "imported top: " ++ ContextMsg ++ "." ])
+        )
+    -> 
+        SharingAs = SharingAs0
+    ;
+        unexpected(this_file, "Error while parsing structure sharing domain.")
+    ).
+
+%-----------------------------------------------------------------------------%
+% Implementation: Printing routines
+%-----------------------------------------------------------------------------%
+
+:- func selector_to_string(tvarset, selector) = string.
+selector_to_string(TVarSet, Selector) =  String :- 
+    (
+        Selector = []
+    -> 
+        String = "[]"
+    ; 
+        SelectorStrings = list.map(unit_selector_to_string(TVarSet), 
+            Selector),
+        string.append_list(["[", 
+            string.join_list(",", SelectorStrings), 
+            "]"], String)
+    ). 
+
+:- func unit_selector_to_string(tvarset, unit_selector) = string.
+unit_selector_to_string(_, termsel(ConsId, Index)) = 
+    string.append_list(["sel(",
+        mercury_cons_id_to_string(ConsId, needs_brackets),
+        ",", 
+        int_to_string(cons_id_arity(ConsId)), 
+        ",",
+        int_to_string(Index), 
+        ")"]).
+
+unit_selector_to_string(TVarSet, typesel(TypeSel)) = 
+    string.append_list(["typesel(", 
+        mercury_type_to_string(TVarSet, bool.no, TypeSel),
+        ")"]).
+
+print_selector(TVarSet, Selector, !IO) :-
+    io.write_string(selector_to_string(TVarSet, Selector), !IO). 
+
+print_datastruct(ProgVarSet, TypeVarSet, DataStruct, !IO) :- 
+    varset.lookup_name(ProgVarSet, DataStruct^sc_var, VarName),
+    io.write_strings(["cel(", VarName, ", "], !IO), 
+    print_selector(TypeVarSet, DataStruct^sc_selector, !IO),
+    io.write_string(")", !IO).
+
+print_structure_sharing_pair(ProgVarSet, TypeVarSet, SharingPair, !IO) :-
+    SharingPair = D1 - D2,
+    io.write_string("pair(", !IO),
+    print_datastruct(ProgVarSet, TypeVarSet, D1, !IO),
+    io.write_string(", ", !IO),
+    print_datastruct(ProgVarSet, TypeVarSet, D2, !IO),
+    io.write_string(")", !IO).
+
+print_structure_sharing(ProgVarSet, TypeVarSet, MaybeLimit, Start, Sep, End, 
+    SharingPairs0, !IO) :- 
+    (
+        MaybeLimit = yes(Limit),
+        list.take_upto(Limit, SharingPairs0, SharingPairs),
+        (
+            Limit >= list.length(SharingPairs0)
+        -> 
+            CompleteList = yes
+        ;
+            CompleteList = no
+        )
+    ;
+        MaybeLimit = no,
+        SharingPairs = SharingPairs0, 
+        CompleteList = yes
+    ), 
+    io.write_string(Start, !IO), 
+    io.write_list(SharingPairs, Sep, 
+        print_structure_sharing_pair(ProgVarSet, TypeVarSet), !IO), 
+    (
+        CompleteList = no
+    -> 
+        io.write_string(Sep, !IO), 
+        io.write_string("...", !IO)
+    ; 
+        true
+    ),
+    io.write_string(End, !IO). 
+
+print_structure_sharing(ProgVarSet, TypeVarSet, SharingPairs, !IO) :- 
+    print_structure_sharing(ProgVarSet, TypeVarSet, no, 
+        "[", ",", "]", SharingPairs, !IO).
+
+:- pred print_structure_sharing_domain(prog_varset::in, tvarset::in, 
+    bool::in, maybe(int)::in, string::in, string::in, string::in, 
+    structure_sharing_domain::in, io__state::di, io__state::uo) is det.
+
+print_structure_sharing_domain(ProgVarSet, TypeVarSet, VerboseTop,
+    MaybeThreshold, Start, Separator, End, SharingAs, !IO) :- 
+    io.write_string(Start, !IO), 
+    (
+        SharingAs = top(Msgs),
+        (
+            VerboseTop = no, 
+            io.write_string("top", !IO)
+        ; 
+            VerboseTop = yes, 
+            io.write_string("top([", !IO), 
+            io.write_list(Msgs, Separator, 
+                io.write_string, !IO), 
+            io.write_string("])", !IO)
+        )
+    ; 
+        SharingAs = bottom, 
+        io.write_string("bottom", !IO)
+    ;
+        SharingAs = real(SharingPairs),
+        print_structure_sharing(ProgVarSet, TypeVarSet, 
+        MaybeThreshold, "[", Separator, "]", SharingPairs, !IO)
+    ), 
+    io.write_string(End, !IO).
+
+print_structure_sharing_domain(ProgVarSet, TypeVarSet, VerboseTop,
+    MaybeThreshold, SharingAs, !IO) :- 
+    print_structure_sharing_domain(ProgVarSet, TypeVarSet, VerboseTop, 
+    MaybeThreshold, "", ",", "", SharingAs, !IO).
+
+dump_maybe_structure_sharing_domain(_, _, no, !IO) :-
+    io.write_string("% no sharing information available.\n", !IO).
+dump_maybe_structure_sharing_domain(ProgVarSet, TypeVarSet, 
+    yes(SharingAs), !IO) :- 
+    print_structure_sharing_domain(ProgVarSet, TypeVarSet, yes,
+        no, "%\t ", "\n%\t", "\n", SharingAs, !IO).
+
+print_interface_structure_sharing_domain(_, _, no, !IO) :- 
+    io.write_string("not_available", !IO).
+print_interface_structure_sharing_domain(ProgVarSet, TypeVarSet, 
+    yes(SharingAs), !IO) :- 
+    io.write_string("yes(", !IO), 
+    print_structure_sharing_domain(ProgVarSet, TypeVarSet, no, 
+        no, SharingAs, !IO), 
+    io.write_string(")", !IO).
+
+%-----------------------------------------------------------------------------%
+
+rename_unit_selector(Subst, !UnitSelector) :- 
+    (
+        !.UnitSelector = termsel(_,_)
+    ;
+        !.UnitSelector = typesel(Type0), 
+        prog_type_subst.apply_subst_to_type(Subst, Type0, Type), 
+        !:UnitSelector = typesel(Type)
+    ).
+rename_selector(TypeSubst, !Selector) :- 
+    list.map(rename_unit_selector(TypeSubst), !Selector).
+rename_datastruct(Dict, Subst, !Data) :- 
+    !.Data = selected_cel(Var0, Sel0), 
+    map.lookup(Dict, Var0, Var),
+    rename_selector(Subst, Sel0, Sel),
+    !:Data = selected_cel(Var, Sel).
+rename_datastruct(Dict, Subst, Data0) = Data :- 
+    rename_datastruct(Dict, Subst, Data0, Data).
+rename_structure_sharing_pair(Dict, TypeSubst, !Pair) :- 
+    !.Pair = D1 - D2, 
+    rename_datastruct(Dict, TypeSubst, D1, Da), 
+    rename_datastruct(Dict, TypeSubst, D2, Db), 
+    !:Pair = Da - Db. 
+rename_structure_sharing(Dict, TypeSubst, !List) :- 
+    list.map(rename_structure_sharing_pair(Dict, TypeSubst), !List).
+rename_structure_sharing_domain(_, _, bottom, bottom). 
+rename_structure_sharing_domain(_, _, X@top(_), X).
+rename_structure_sharing_domain(Dict, TypeSubst, 
+        real(List0), real(List)):-
+    rename_structure_sharing(Dict, TypeSubst, List0, List).
+
+%-----------------------------------------------------------------------------%
+:- func this_file = string.
+this_file = "prog_ctgc.m".
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.151
diff -u -d -r1.151 prog_data.m
--- compiler/prog_data.m	16 Jan 2006 03:08:14 -0000	1.151
+++ compiler/prog_data.m	14 Feb 2006 09:34:31 -0000
@@ -320,6 +320,60 @@
 
 %-----------------------------------------------------------------------------%
 %
+% Stuff for the `structure_sharing_info' pragma.
+%
+
+   
+    % Whenever structure sharing analysis is unable to determine a good
+    % approximation of the set of structure sharing pairs that might exist
+    % during the execution of a program, it must use "top" as the only safe
+    % approximation. In order to collect some useful basic feedback information
+    % as to `why' a top was generated, we use: 
+:- type top_feedback == string. 
+
+    % Elements of the structure sharing domain lattice are either bottom
+    % (no structure sharing), top (any kind of structure sharing), or
+    % a list of structure sharing pairs. 
+    %
+:- type structure_sharing_domain
+    --->    bottom
+    ;       real(structure_sharing)
+    ;       top(list(top_feedback)). 
+
+    % Public representation of structure sharing.
+    %
+:- type structure_sharing == list(structure_sharing_pair).
+
+    % A structure sharing pair represents the information that two
+    % datastructures might be represented by the same memoryspace, hence
+    % its representation as a pair of datastructures.
+    %
+:- type structure_sharing_pair == pair(datastruct).
+
+    % A datastructure is a concept that designates a particular subterm of the
+    % term to which a particular variable may be bound. 
+    %
+:- type datastruct 
+    --->    selected_cel(
+                sc_var ::   prog_var,
+                sc_selector ::  selector
+            ).
+
+    % A selector describes a path in a type-tree.
+    %
+:- type selector == list(unit_selector).
+
+    % Unit-selectors are either term selectors or type selectors.  A term
+    % selector selects a subterm f/n of a term, where f is a functor
+    % (identified by the cons_id), and n an integer.  A type selector
+    % designates any subterm that has that specific type.
+    %
+:- type unit_selector 
+    --->    termsel(cons_id, int)       % term selector
+    ;       typesel(mer_type).          % type selector
+
+%-----------------------------------------------------------------------------%
+%
 % Stuff for the `unused_args' pragma
 %
 
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.96
diff -u -d -r1.96 prog_io_pragma.m
--- compiler/prog_io_pragma.m	28 Nov 2005 04:11:52 -0000	1.96
+++ compiler/prog_io_pragma.m	14 Feb 2006 09:34:34 -0000
@@ -43,6 +43,7 @@
 
 :- import_module libs.compiler_util.
 :- import_module libs.rat.
+:- import_module parse_tree.prog_ctgc.
 :- import_module parse_tree.prog_data.
 :- import_module parse_tree.prog_io.
 :- import_module parse_tree.prog_io_goal.
@@ -1169,6 +1170,52 @@
         (pred(Name::in, Arity::in, Pragma::out) is det :-
             Pragma = check_termination(Name, Arity)),
         PragmaTerms, ErrorTerm, Result).
+
+parse_pragma_type(ModuleName, "structure_sharing", PragmaTerms, ErrorTerm, 
+        _VarSet, Result) :- 
+    (
+        PragmaTerms = [
+            PredAndModesTerm0, 
+            HeadVarsTerm, 
+            HeadVarTypesTerm, 
+            SharingInformationTerm
+        ],
+        parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
+            ErrorTerm, "`:- pragma structure_sharing' declaration",
+            NameAndModesResult),
+        NameAndModesResult = ok(PredName - PredOrFunc, ModeList),
+
+        % Parse the headvariables: 
+        HeadVarsTerm = term__functor(term__atom("vars"), ListHVTerm, _),
+        term__vars_list(ListHVTerm, HeadVarsGeneric),
+        list__map(term__coerce_var, HeadVarsGeneric, HeadVars),
+
+        % Parse the types: 
+        HeadVarTypesTerm = term__functor(term__atom("types"), ListTypeTerms, 
+            _), 
+        parse_types(ListTypeTerms, ok(Types)), 
+
+        % Parse the actual structure sharing information.
+        
+        (
+            SharingInformationTerm = term__functor(term__atom("not_available"),
+                _, _),
+            MaybeSharingAs = no
+        ;
+            SharingInformationTerm = term__functor(term__atom("yes"), 
+                SharingTerm, _), 
+            SharingTerm = [ SharingAsTerm ],
+            MaybeSharingAs = yes(parse_structure_sharing_domain(SharingAsTerm))
+        ), 
+
+        Result0 = ok(pragma(user, structure_sharing(PredOrFunc, PredName, 
+            ModeList, HeadVars, Types, MaybeSharingAs)))
+    ->
+        Result = Result0
+    ;
+        Result = error("syntax error in `:- pragma structure_sharing' " ++
+            "declaration", ErrorTerm)
+    ).
 
 parse_pragma_type(ModuleName, "exceptions", PragmaTerms, ErrorTerm, _VarSet,
         Result) :-
Index: compiler/prog_item.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_item.m,v
retrieving revision 1.2
diff -u -d -r1.2 prog_item.m
--- compiler/prog_item.m	16 Jan 2006 03:08:14 -0000	1.2
+++ compiler/prog_item.m	14 Feb 2006 09:34:35 -0000
@@ -649,7 +649,28 @@
     ;       mode_check_clauses(
                 mode_check_clause_name  :: sym_name,
                 mode_check_clause_arity :: arity
-            ).
+            )
+
+    %
+    % CTGC pragma: structure sharing / structure reuse analysis.
+    %
+    ;
+            structure_sharing(
+                sharing_p_or_f          :: pred_or_func,
+                sharing_name            :: sym_name,
+                sharing_mode            :: list(mer_mode),
+                sharing_headvars        :: prog_vars, 
+                sharing_headvartypes    :: list(mer_type),
+                sharing_description     :: maybe(structure_sharing_domain)
+            )
+            % After structure sharing analysis, the compiler generates
+            % structure sharing pragmas to be stored in and read from
+            % optimization interface files. 
+            %
+            % The list of modes consists of the declared argmodes (or inferred
+            % argmodes if there are no declared ones). 
+
+    .
 
 %-----------------------------------------------------------------------------%
 %
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.36
diff -u -d -r1.36 recompilation.version.m
--- compiler/recompilation.version.m	16 Jan 2006 03:08:14 -0000	1.36
+++ compiler/recompilation.version.m	14 Feb 2006 09:34:37 -0000
@@ -597,6 +597,9 @@
 is_pred_pragma(termination_info(PredOrFunc, Name, Modes, _, _),
         yes(yes(PredOrFunc) - Name / Arity)) :-
     adjust_func_arity(PredOrFunc, Arity, list__length(Modes)).  
+is_pred_pragma(structure_sharing(PredOrFunc, Name, Modes, _, _, _),
+        yes(yes(PredOrFunc) - Name / Arity)) :-
+    adjust_func_arity(PredOrFunc, Arity, list__length(Modes)).  
 is_pred_pragma(termination2_info(PredOrFunc, Name, Modes, _, _, _),
         yes(yes(PredOrFunc) - Name / Arity)) :-
     adjust_func_arity(PredOrFunc, Arity, list__length(Modes)).  
Index: compiler/structure_sharing.analysis.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/structure_sharing.analysis.m,v
retrieving revision 1.1
diff -u -d -r1.1 structure_sharing.analysis.m
--- compiler/structure_sharing.analysis.m	16 Dec 2005 12:17:55 -0000	1.1
+++ compiler/structure_sharing.analysis.m	14 Feb 2006 09:34:38 -0000
@@ -1,5 +1,7 @@
 %-----------------------------------------------------------------------------%
-% Copyright (C) 2005 The University of Melbourne.
+% 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.
 %-----------------------------------------------------------------------------%
@@ -7,7 +9,8 @@
 % File: structure_sharing.analysis.m
 % Main authors: nancy
 %
-% Implementation of the data structure analysis. 
+% Implementation of the structure sharing analysis needed for compile-time
+% garbage collection (CTGC). 
 %
 %-----------------------------------------------------------------------------%
 
@@ -15,17 +18,671 @@
 
 :- interface.
 
-:- import_module hlds__hlds_module.
+:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_pred.
+:- import_module transform_hlds.ctgc.structure_sharing.domain.
 
 :- import_module io.
 
-:- pred data_structure_sharing_analysis(module_info::in, module_info::out, 
-	io__state::di, io__state::uo) is det.
+:- pred structure_sharing_analysis(module_info::in, module_info::out, 
+    sharing_as_table::out, io::di, io::uo) is det.
+
+:- pred write_pred_sharing_info(module_info::in, pred_id::in, 
+    io::di, io::uo) is det.
 
 :- implementation. 
 
+:- import_module check_hlds.inst_match.
+:- import_module check_hlds.mode_util.
+:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_goal.
+:- import_module hlds.passes_aux.
+:- import_module libs.compiler_util.
+:- import_module libs.globals.
+:- import_module libs.options.
+:- import_module ll_backend.liveness.
+:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.mercury_to_mercury.
+:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_out.
+:- import_module transform_hlds.ctgc.fixpoint_table.
+:- import_module transform_hlds.ctgc.util.
+:- import_module transform_hlds.dependency_graph.
+
+:- import_module bool. 
 :- import_module io. 
+:- import_module list.
+:- import_module map.
+:- import_module std_util.
+:- import_module string.
+:- import_module term.
 
-data_structure_sharing_analysis(!HLDS, !IO). 
+structure_sharing_analysis(!ModuleInfo, SharingTable, !IO):-
+    % preliminary step: 
+    % annotate the liveness (as in liveness.m)
+    annotate_liveness(!ModuleInfo, !IO),
+    % load all structure sharing information present in the HLDS. 
+    load_structure_sharing_table(!.ModuleInfo, SharingTable0), 
+
+    % analysis
+    sharing_analysis(!ModuleInfo, SharingTable0, SharingTable, !IO).
+    
+%-----------------------------------------------------------------------------%
+% Preliminary steps.
+
+:- pred load_structure_sharing_table(module_info::in, sharing_as_table::out)
+    is det.
+
+load_structure_sharing_table(ModuleInfo, SharingTable) :- 
+    module_info_predids(ModuleInfo, PredIds), 
+    list.foldl(load_structure_sharing_table_2(ModuleInfo), PredIds, 
+        sharing_as_table_init, SharingTable). 
+
+:- pred load_structure_sharing_table_2(module_info::in, pred_id::in, 
+    sharing_as_table::in, sharing_as_table::out) is det.
+load_structure_sharing_table_2(ModuleInfo, PredId, !SharingTable) :- 
+    module_info_pred_info(ModuleInfo, PredId, PredInfo), 
+    list.foldl(load_structure_sharing_table_3(ModuleInfo, PredId), 
+        pred_info_procids(PredInfo), !SharingTable).
+
+:- pred load_structure_sharing_table_3(module_info::in, pred_id::in, 
+    proc_id::in, sharing_as_table::in, sharing_as_table::out) is det.
+load_structure_sharing_table_3(ModuleInfo, PredId, ProcId, !SharingTable):- 
+    module_info_proc_info(ModuleInfo, PredId, ProcId, ProcInfo), 
+    proc_info_get_structure_sharing(ProcInfo, MaybePublicSharing),
+    (
+        MaybePublicSharing = yes(PublicSharing), 
+        sharing_as_table_set(proc(PredId, ProcId),     
+            from_structure_sharing_domain(PublicSharing), !SharingTable)
+    ;
+        MaybePublicSharing = no
+    ).
+
+    % Annotate the HLDS with pre-birth and post-death information, as
+    % used by the liveness pass (liveness.m). This information is used to 
+    % eliminate useless sharing pairs during sharing analysis. 
+:- pred annotate_liveness(module_info::in, module_info::out, io::di, 
+    io::uo) is det.
+
+annotate_liveness(!ModuleInfo, !IO):- 
+    process_all_nonimported_nonaditi_procs(
+        update_proc_io(detect_liveness_proc), !ModuleInfo, !IO).
+
+%-----------------------------------------------------------------------------%
+
+:- pred sharing_analysis(module_info::in, module_info::out, 
+    sharing_as_table::in, sharing_as_table::out, io::di, 
+    io::uo) is det.
+
+sharing_analysis(!ModuleInfo, !SharingTable, !IO):- 
+    % Perform the analysis based on the strongly connected components. 
+    
+    module_info_ensure_dependency_info(!ModuleInfo), 
+    module_info_get_maybe_dependency_info(!.ModuleInfo, MaybeDepInfo), 
+    (
+        MaybeDepInfo = yes(DepInfo),
+        hlds_dependency_info_get_dependency_ordering(DepInfo, 
+            SCCs), 
+        list.foldl2(analyse_scc(!.ModuleInfo), SCCs, !SharingTable, 
+            !IO)
+    ;
+        MaybeDepInfo = no,
+        unexpected(this_file, "No dependency information.")
+    ), 
+    
+    % Record the sharing results in the HLDS
+    map.foldl(save_sharing_in_module_info, !.SharingTable, 
+        !ModuleInfo).
+
+
+:- pred save_sharing_in_module_info(pred_proc_id::in, sharing_as::in, 
+    module_info::in, module_info::out) is det.
+
+save_sharing_in_module_info(PredProcId, SharingAs, !ModuleInfo) :- 
+    module_info_pred_proc_info(!.ModuleInfo, PredProcId, PredInfo0, 
+        ProcInfo0),
+    proc_info_set_structure_sharing( 
+        to_structure_sharing_domain(SharingAs), 
+        ProcInfo0, ProcInfo), 
+    module_info_set_pred_proc_info(PredProcId, PredInfo0, 
+        ProcInfo, !ModuleInfo).
+
+:- pred analyse_scc(module_info::in, list(pred_proc_id)::in, 
+    sharing_as_table::in, sharing_as_table::out, 
+    io::di, io::uo) is det.
+
+analyse_scc(ModuleInfo, SCC, !SharingTable, !IO):-
+    (
+        ctgc.util.preds_requiring_no_analysis(ModuleInfo, SCC)
+    -> 
+        true
+    ;
+        analyse_scc_until_fixpoint(ModuleInfo, SCC, 
+            !.SharingTable, ss_fixpoint_table_init(SCC), 
+            FixpointTable, !IO),
+        list.foldl(update_sharing_in_table(FixpointTable), SCC, 
+            !SharingTable)
+    ).
+
+:- pred analyse_scc_until_fixpoint(module_info::in, list(pred_proc_id)::in,
+    sharing_as_table::in, ss_fixpoint_table::in, ss_fixpoint_table::out, 
+    io::di, io::uo) is det.
+
+analyse_scc_until_fixpoint(ModuleInfo, SCC, SharingTable, 
+    !FixpointTable, !IO) :- 
+    list.foldl2(analyse_pred_proc(ModuleInfo, SharingTable), 
+        SCC, !FixpointTable, !IO), 
+    (
+        ss_fixpoint_table_stable(!.FixpointTable)
+    ->
+        true
+    ;
+        ss_fixpoint_table_new_run(!FixpointTable),
+        analyse_scc_until_fixpoint(ModuleInfo, SCC, SharingTable, 
+            !FixpointTable, !IO)
+    ).
+
+%-----------------------------------------------------------------------------%
+% The heart of it all, analysing a single procedure: analyse_pred_proc.
+%-----------------------------------------------------------------------------%
+:- pred analyse_pred_proc(module_info::in, sharing_as_table::in, 
+    pred_proc_id::in, ss_fixpoint_table::in, ss_fixpoint_table::out, 
+    io::di, io::uo) is det.
+
+analyse_pred_proc(ModuleInfo, SharingTable, PredProcId, 
+    !FixpointTable, !IO) :- 
+
+    % Collect relevant compiler options. 
+    globals.io_lookup_bool_option(very_verbose, Verbose, !IO),
+    globals.io_lookup_int_option(structure_sharing_widening, 
+        WideningLimit, !IO),
+
+    % Collect relevant procedure information.
+    module_info_pred_proc_info(ModuleInfo, PredProcId, PredInfo, ProcInfo),
+    PredProcId = proc(PredId, ProcId), 
+    proc_info_headvars(ProcInfo, HeadVars), 
+
+    % Write progress message for the start of analysing current procedure.
+    Run = ss_fixpoint_table_which_run(!.FixpointTable),
+    TabledAsDescr = ss_fixpoint_table_get_short_description(
+        PredProcId, !.FixpointTable),
+    passes_aux.write_proc_progress_message(
+        "% Sharing analysis (run " ++ string.int_to_string(Run) ++
+        ") ", PredId, ProcId, ModuleInfo, !IO),
+
+    % In some cases the sharing can be predicted to be bottom, in which 
+    % case a full sharing analysis is not needed.
+    Sharing0 = structure_sharing.domain.init,
+    (
+        bottom_sharing_is_safe_approximation(ModuleInfo, ProcInfo)
+    ->
+        maybe_write_string(Verbose, "\t\t: bottom predicted", !IO),
+        Sharing = Sharing0
+    ;
+        % Start analysis.
+        proc_info_goal(ProcInfo, Goal), 
+        analyse_goal(ModuleInfo, PredInfo, ProcInfo, SharingTable,
+            Goal, 
+            !FixpointTable, Sharing0, Sharing1, !IO),
+        FullAsDescr = short_description(Sharing1), 
+
+        structure_sharing.domain.project(HeadVars, Sharing1, Sharing2),
+        ProjAsDescr = short_description(Sharing2),
+
+        structure_sharing.domain.apply_widening(ModuleInfo, ProcInfo, 
+           WideningLimit, WideningDone, Sharing2, Sharing3), 
+        (
+            WideningDone = yes, 
+            WidenAsDescr = short_description(Sharing3)
+        ; 
+            WideningDone = no, 
+            WidenAsDescr = "-"
+        ),
+
+        maybe_write_string(Verbose, "\t\t: " ++
+            TabledAsDescr ++ "->" ++
+            FullAsDescr ++ "/" ++
+            ProjAsDescr ++ "/" ++
+            WidenAsDescr, !IO), 
+
+        Sharing = Sharing3
+    ),
+    ss_fixpoint_table_new_as(ModuleInfo, ProcInfo, PredProcId, 
+        Sharing, !FixpointTable),
+    
+    maybe_write_string(Verbose, "\t\t (ft = " ++ 
+        ss_fixpoint_table_description(!.FixpointTable) ++
+        ")\n", !IO).
+        
+:- pred analyse_goal(module_info::in, pred_info::in, proc_info::in, 
+    sharing_as_table::in, hlds_goal::in, ss_fixpoint_table::in, 
+    ss_fixpoint_table::out, sharing_as::in, sharing_as::out, 
+    io::di, io::uo) is det.
+analyse_goal(ModuleInfo, PredInfo, ProcInfo, SharingTable, Goal, 
+    !FixpointTable, !SharingAs, !IO) :- 
+    Goal = GoalExpr - GoalInfo, 
+
+    (
+        GoalExpr = conj(Goals),
+        list.foldl3(analyse_goal(ModuleInfo, PredInfo, ProcInfo, 
+            SharingTable), Goals, !FixpointTable, !SharingAs,
+            !IO)
+    ;
+        GoalExpr = call(CalledPredId, CalledProcId, Args, _, _, _),
+        CalledPredProcId = proc(CalledPredId, CalledProcId),
+        lookup_sharing(ModuleInfo, SharingTable, CalledPredProcId, 
+            !FixpointTable, CalledSharing),
+        
+        % Rename
+        proc_info_vartypes(ProcInfo, AllTypes), 
+        list.map(map.lookup(AllTypes), Args, ActualTypes), 
+
+        pred_info_typevarset(PredInfo, ActualTVarset), 
+
+        rename_using_module_info(ModuleInfo, CalledPredProcId, 
+            Args, ActualTypes, ActualTVarset, CalledSharing, RenamedSharing), 
+
+        % Combine
+        !:SharingAs = comb(ModuleInfo, ProcInfo, 
+            RenamedSharing, !.SharingAs)
+    ;
+        GoalExpr = generic_call(_GenDetails, _, _, _),
+        goal_info_get_context(GoalInfo, Context), 
+        context_to_string(Context, ContextString), 
+        !:SharingAs = top_sharing( "generic call (" ++ 
+            ContextString ++ ")", !.SharingAs)
+    ;
+        GoalExpr = switch(_, _, Cases),
+        list.foldl3(analyse_case(ModuleInfo, PredInfo, ProcInfo,
+            SharingTable, !.SharingAs), 
+            Cases, !FixpointTable, 
+            structure_sharing.domain.init, !:SharingAs,
+            !IO)
+    ;
+        GoalExpr = unify(_, _, _, Unification, _),
+        !:SharingAs = add(ModuleInfo, ProcInfo, Unification, GoalInfo, 
+            !.SharingAs)
+
+    ;
+        GoalExpr = disj(Goals),
+        SharingBase = !.SharingAs, 
+        AnalyseGoal = ( pred(G::in, 
+                FP0::in, FP::out, Sh0::in, Sh::out, 
+                IO0::di, IO1::uo) is det :- 
+            (
+            analyse_goal(ModuleInfo, PredInfo, ProcInfo,
+                SharingTable, G, FP0, FP, 
+                SharingBase, Sh1, IO0, IO1),
+            Sh = least_upper_bound(ModuleInfo, ProcInfo, Sh0, Sh1)
+            )),
+        list.foldl3(AnalyseGoal, Goals, !FixpointTable, 
+            structure_sharing.domain.init, !:SharingAs, !IO)
+    ;
+        GoalExpr = not(_Goal)
+        % XXX Check theory, but a negated goal can not create bindings,
+        % hence it also can not create additional sharing.
+
+    ;
+        GoalExpr = scope(_, _),
+        % XXX Check theory, check meaing of "scope/2" goal.
+        goal_info_get_context(GoalInfo, Context), 
+        context_to_string(Context, ContextString), 
+        !:SharingAs = top_sharing("scope (" ++ ContextString ++ 
+            ")", !.SharingAs)
+
+    ;
+        GoalExpr = if_then_else(_, IfGoal, ThenGoal, ElseGoal),
+        analyse_goal(ModuleInfo, PredInfo, ProcInfo, SharingTable, 
+            IfGoal, !FixpointTable, !.SharingAs, IfSharingAs, !IO),
+        analyse_goal(ModuleInfo, PredInfo, ProcInfo, SharingTable, 
+            ThenGoal, !FixpointTable, IfSharingAs, ThenSharingAs,
+            !IO),
+        analyse_goal(ModuleInfo, PredInfo, ProcInfo, SharingTable, 
+            ElseGoal, !FixpointTable, !.SharingAs, ElseSharingAs,
+            !IO),
+        !:SharingAs = least_upper_bound(ModuleInfo, ProcInfo, 
+            ThenSharingAs, ElseSharingAs)
+    ;
+        GoalExpr = foreign_proc(_Attrs, _ForeignPredId, _ForeignProcId,
+            _ForeignArgs, _, _),
+        % XXX User annotated structure sharing information is not yet
+        % supported.
+        goal_info_get_context(GoalInfo, Context), 
+        context_to_string(Context, ContextString), 
+        !:SharingAs = top_sharing("foreign_proc not handles yet (" 
+                ++ ContextString ++ ")", !.SharingAs)
+    ;
+        GoalExpr = par_conj(_),
+        goal_info_get_context(GoalInfo, Context), 
+        context_to_string(Context, ContextString), 
+        !:SharingAs = top_sharing("par_conj (" ++ ContextString ++ 
+            ")", !.SharingAs)
+
+    ;
+        GoalExpr = shorthand(_),
+        unexpected(this_file, "analyse_goal: shorthand goal.")
+    ).
+
+
+:- pred analyse_case(module_info::in, pred_info::in, proc_info::in, 
+    sharing_as_table::in, sharing_as::in, case::in, 
+    ss_fixpoint_table::in, ss_fixpoint_table::out, 
+    sharing_as::in, sharing_as::out, 
+    io::di, io::uo) is det.
+analyse_case(ModuleInfo, PredInfo, ProcInfo, SharingTable, Sharing0, 
+    Case, !FixpointTable, !Sharing, !IO) :- 
+    Case = case(_, Goal), 
+    analyse_goal(ModuleInfo, PredInfo, ProcInfo, SharingTable, Goal,
+        !FixpointTable, Sharing0, CaseSharing, !IO), 
+    !:Sharing = least_upper_bound(ModuleInfo, ProcInfo, !.Sharing, 
+        CaseSharing).
+
+%-----------------------------------------------------------------------------%
+
+    % Lookup the sharing information of a procedure identified by its
+    % pred_proc_id. 
+    % 1 - first look in the fixpoint table (which may change the state
+    %     of this table wrt recursiveness); 
+    % 2 - then look in sharing_s_table (as we might already have analysed
+    %     the predicate, if defined in same module, or analysed in other
+    %     imported module)
+    % 3 - try to predict bottom; 
+    % 4 - react appropriately if the calls happen to be to 
+    %     * either compiler generated predicates
+    %     * or predicates from builtin.m and private_builtin.m
+:- pred lookup_sharing(module_info::in, sharing_as_table::in, pred_proc_id::in,
+    ss_fixpoint_table::in, ss_fixpoint_table::out, sharing_as::out) is det.
+
+lookup_sharing(ModuleInfo, SharingTable, PredProcId, !FixpointTable, 
+    SharingAs) :- 
+    (
+        % 1 -- check fixpoint table
+        ss_fixpoint_table_get_as(PredProcId, SharingAs0, 
+            !FixpointTable)
+    -> 
+        SharingAs = SharingAs0
+    ;
+        % 2 -- look up in SharingTable
+        SharingAs0 = sharing_as_table_search(PredProcId, SharingTable)
+    -> 
+        SharingAs = SharingAs0
+    ;
+        % 3 -- predict bottom sharing
+        %
+        % If it is neither in the fixpoint table, nor in the sharing
+        % table, then this means that we have never analysed the called
+        % procedure, yet in some cases we can still simply predict that
+        % the sharing the called procedure creates is bottom. 
+        predict_called_pred_is_bottom(ModuleInfo, PredProcId)
+    -> 
+        SharingAs = structure_sharing.domain.init
+    ;
+        % 4 -- use top-sharing with appropriate message. 
+        SharingAs = top_sharing_not_found(ModuleInfo, PredProcId)
+    ).
+        
+:- pred predict_called_pred_is_bottom(module_info::in, pred_proc_id::in)
+    is semidet.
+
+predict_called_pred_is_bottom(ModuleInfo, PredProcId) :- 
+    module_info_pred_proc_info(ModuleInfo, PredProcId, PredInfo, ProcInfo),
+    (
+        % 1. inferred determinism is erroneous/failure. 
+        proc_info_inferred_determinism(ProcInfo, Determinism), 
+        (
+            Determinism = erroneous
+        ; 
+            Determinism = failure
+        )
+    ;
+        % 2. bottom_sharing_is_safe_approximation
+        bottom_sharing_is_safe_approximation(ModuleInfo, ProcInfo)
+    ;
+        % 3. call to builtin/private_builtin procedures, namely
+        % "unify", "index" or "compare".
+        PredName = pred_info_name(PredInfo),
+        PredArity = pred_info_orig_arity(PredInfo),
+        (
+            special_pred_name_arity(_, PredName, _, PredArity)
+        ;
+            special_pred_name_arity(_, _, PredName, PredArity)
+        )
+    ;
+        % 4. (XXX UNSAFE!! To verify) any call to private_builtin and builtin
+        % procedures. 
+        PredModule = pred_info_module(PredInfo),
+        (
+            mercury_private_builtin_module(PredModule)
+        ; 
+            mercury_public_builtin_module(PredModule)
+        )
+    ).
+
+:- func top_sharing_not_found(module_info, pred_proc_id) = sharing_as.
+
+top_sharing_not_found(ModuleInfo, PredProcId) = TopSharing :- 
+    module_info_pred_proc_info(ModuleInfo, PredProcId, PredInfo, _),
+    PredProcId = proc(PredId, ProcId),
+    PredModuleName = pred_info_module(PredInfo),
+
+    TopSharing = top_sharing("Lookup sharing failed for " ++
+        sym_name_to_escaped_string(PredModuleName) ++ "." ++
+        pred_info_name(PredInfo) ++ "/" ++
+        int_to_string(pred_info_orig_arity(PredInfo)) ++ " (id = " ++
+        int_to_string(pred_id_to_int(PredId)) ++ "," ++
+        int_to_string(proc_id_to_int(ProcId))).
+    
+
+%-----------------------------------------------------------------------------%
+
+    % Predicate succeeds if the sharing of a procedure can safely be 
+    % approximated by "bottom", simply by looking at the modes and
+    % types of the arguments. 
+    %
+    %
+:- pred bottom_sharing_is_safe_approximation(module_info::in, 
+    proc_info::in) is semidet.  
+
+bottom_sharing_is_safe_approximation(ModuleInfo, ProcInfo):- 
+    proc_info_headvars(ProcInfo, HeadVars),
+    proc_info_argmodes(ProcInfo, Modes), 
+    proc_info_vartypes(ProcInfo, VarTypes),
+    list.map(map.lookup(VarTypes), HeadVars, Types),
+
+    MapToPair = (func(M, T) = Result :- Result = M - T), 
+    ModeTypePairs = list.map_corresponding(MapToPair, Modes, Types),
+
+    Test = ( pred(Pair::in) is semidet :-
+            Pair = Mode - Type,
+
+            % mode is not unique nor clobbered.
+            mode_get_insts(ModuleInfo, Mode, _LeftInst, 
+                RightInst), 
+            \+ inst_is_unique(ModuleInfo, RightInst),
+            \+ inst_is_clobbered(ModuleInfo, RightInst),
+
+            % mode is output.
+            mode_to_arg_mode(ModuleInfo, Mode, Type, ArgMode),
+            ArgMode = top_out,
+
+            % type is not primitive
+            \+ type_util.type_is_atomic(Type, ModuleInfo)
+        ),
+
+    list.filter(Test, ModeTypePairs, []).
+
+%-----------------------------------------------------------------------------%
+
+:- pred update_sharing_in_table(ss_fixpoint_table::in, pred_proc_id::in,
+    sharing_as_table::in, sharing_as_table::out) is det.
+update_sharing_in_table(FixpointTable, PredProcId, !SharingTable):- 
+    sharing_as_table_set(PredProcId,
+        ss_fixpoint_table_get_final_as(PredProcId, FixpointTable),
+        !SharingTable).
+
+%-----------------------------------------------------------------------------%
+%
+% Structure sharing fixpoint table. 
+%
+
+:- type ss_fixpoint_table == fixpoint_table(pred_proc_id, sharing_as).
+
+    % Initialise the fixpoint table for the given set of pred_proc_id's. 
+    %
+:- func ss_fixpoint_table_init(list(pred_proc_id)) = ss_fixpoint_table.
+
+    % Add the results of a new analysis pass to the already existing
+    % fixpoint table. 
+    %
+:- pred ss_fixpoint_table_new_run(ss_fixpoint_table::in, 
+    ss_fixpoint_table::out) is det.
+
+    % The fixpoint table keeps track of the number of analysis passes. This
+    % predicate returns this number.
+    %
+:- func ss_fixpoint_table_which_run(ss_fixpoint_table) = int. 
+
+    % A fixpoint is reached if all entries in the table are stable,
+    % i.e. haven't been modified by the last analysis pass. 
+    %
+:- pred ss_fixpoint_table_stable(ss_fixpoint_table::in) is semidet.
+
+    % Give a string description of the state of the fixpoint table. 
+:- func ss_fixpoint_table_description(ss_fixpoint_table) = string.
+
+    % Enter the newly computed structure sharing description for a given
+    % procedure.  If the description is different from the one that was
+    % already stored for that procedure, the stability of the fixpoint
+    % table is set to "unstable". 
+    % Software error if the procedure is not in the fixpoint table. 
+:- pred ss_fixpoint_table_new_as(module_info::in, proc_info::in, 
+    pred_proc_id::in, sharing_as::in, 
+    ss_fixpoint_table::in, ss_fixpoint_table::out) is det.
+
+    % Retreive the structure sharing description for a given pred_proc_id.
+    %
+    % If the id is part of the fixpoint table, but does not yet record any
+    % sharing information about that pred_proc_id, then this means that the
+    % set of pred_proc_id's to which the fixpoint table relates is mutually
+    % recursive, hence the table is characterised as recursive. 
+    %
+    % If the id is not part of the fixpoint table: fail. 
+    %
+:- pred ss_fixpoint_table_get_as(pred_proc_id::in, sharing_as::out, 
+    ss_fixpoint_table::in, ss_fixpoint_table::out) is semidet.
+
+:- func ss_fixpoint_table_get_short_description(pred_proc_id, 
+    ss_fixpoint_table) = string. 
+
+    % Retreive the structure sharing information without changing the
+    % table. To be used after fixpoint has been reached. 
+    % Software error if the procedure is not in the table.
+:- func ss_fixpoint_table_get_final_as(pred_proc_id, 
+    ss_fixpoint_table) = sharing_as. 
+
+    % Same as ss_fixpoint_table_get_final_as, yet fails instead of aborting
+    % if the procedure is not in the table.
+:- func ss_fixpoint_table_get_final_as_semidet(pred_proc_id,
+    ss_fixpoint_table) = sharing_as is semidet. 
+
+
+%-----------------------------------------------------------------------------%
+
+:- func wrapped_init(pred_proc_id) = sharing_as. 
+wrapped_init(_Id) = structure_sharing.domain.init. 
+
+ss_fixpoint_table_init(Keys) = fixpoint_table.init(wrapped_init, Keys).
+
+ss_fixpoint_table_new_run(!Table) :- 
+    fixpoint_table.new_run(!Table).
+
+ss_fixpoint_table_which_run(Tin) = fixpoint_table.which_run(Tin).
+
+ss_fixpoint_table_stable(Table) :- fixpoint_table.fixpoint_reached(Table).
+
+ss_fixpoint_table_description(Table) = fixpoint_table.description(Table).
+
+ss_fixpoint_table_new_as(ModuleInfo, ProcInfo, Id, SharingAs, !Table):-
+    fixpoint_table.add(
+        structure_sharing.domain.is_subsumed_by(ModuleInfo, ProcInfo),
+        Id, SharingAs, !Table).
+
+ss_fixpoint_table_get_as(PredProcId, SharingAs, !Table) :- 
+    fixpoint_table.get(PredProcId, SharingAs, !Table).
+
+ss_fixpoint_table_get_short_description(PredProcId, Table) = Descr :- 
+    (
+        As = ss_fixpoint_table_get_final_as_semidet(PredProcId, Table)
+    ->
+        Descr = short_description(As)
+    ;
+        Descr = "-"
+    ).
+
+ss_fixpoint_table_get_final_as(PredProcId, T) = 
+    fixpoint_table.get_final(PredProcId, T).
+
+ss_fixpoint_table_get_final_as_semidet(PredProcId, T) =
+    fixpoint_table.get_final_semidet(PredProcId, T). 
+
+%-----------------------------------------------------------------------------%
+
+write_pred_sharing_info(ModuleInfo, PredId, !IO) :- 
+    module_info_pred_info(ModuleInfo, PredId, PredInfo), 
+    pred_info_import_status(PredInfo, ImportStatus), 
+    (
+        ( 
+            ImportStatus = exported 
+        ;
+            ImportStatus = opt_exported
+        ),
+        \+ is_unify_or_compare_pred(PredInfo)
+    ->
+        PredName = pred_info_name(PredInfo),
+        ProcIds = pred_info_procids(PredInfo),
+        PredOrFunc = pred_info_is_pred_or_func(PredInfo),
+        ModuleName = pred_info_module(PredInfo),
+        pred_info_procedures(PredInfo, ProcTable),
+        pred_info_context(PredInfo, Context),
+        SymName = qualified(ModuleName, PredName),
+        pred_info_typevarset(PredInfo, TypeVarSet), 
+        list.foldl(
+            (pred(ProcId::in, IO1::di, IO2::uo) is det :- 
+                write_proc_sharing_info(PredId, ProcId,
+                ProcTable, PredOrFunc, SymName, Context, 
+                TypeVarSet, IO1, IO2)
+            ),
+            ProcIds, !IO)
+    ;
+        true
+    ).
+
+:- pred write_proc_sharing_info(pred_id::in, proc_id::in, proc_table::in, 
+    pred_or_func::in, sym_name::in, prog_context::in, tvarset::in, 
+    io::di, io::uo) is det.
+write_proc_sharing_info(_PredId, ProcId, ProcTable, PredOrFunc, SymName, 
+    Context, TypeVarSet, !IO) :- 
+    globals.io_lookup_bool_option(structure_sharing_analysis, 
+        SharingAnalysis, !IO), 
+    (
+        SharingAnalysis = yes
+    -> 
+        map.lookup(ProcTable, ProcId, ProcInfo),
+        proc_info_get_structure_sharing(ProcInfo, MaybeSharingAs), 
+        proc_info_declared_argmodes(ProcInfo, Modes),   
+        proc_info_varset(ProcInfo, VarSet), 
+        proc_info_headvars(ProcInfo, HeadVars), 
+        proc_info_vartypes(ProcInfo, VarTypes), 
+        list.map(map.lookup(VarTypes), HeadVars, HeadVarTypes),
+        write_pragma_structure_sharing_info(PredOrFunc, SymName, Modes, 
+            Context, HeadVars, yes(VarSet), HeadVarTypes, yes(TypeVarSet), 
+            MaybeSharingAs, !IO)
+    ;
+        true
+    ).
+
+%-----------------------------------------------------------------------------%
+:- func this_file = string.
+this_file = "structure_sharing.analysis.m".
 
 :- end_module transform_hlds.ctgc.structure_sharing.analysis.
