mercury/compiler/term_norm.m

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1997-2005 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: term_norm.m
% Main author: crs
%
% This modules defines predicates for computing functor norms.
%
%-----------------------------------------------------------------------------%

:- module transform_hlds.term_norm.

:- interface.

:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
:- import_module libs.globals.
:- import_module parse_tree.prog_data.

:- import_module int.
:- import_module list.

%-----------------------------------------------------------------------------%

    % The functor_info type contains information about how the weight of a
    % term is calculated.
    %
:- type functor_info.

    % This predicate sets the functor_info depending on the value of the
    % termination_norm or termination2_norm option.
    %
:- func set_functor_info(globals.termination_norm, module_info) = functor_info.  

    % This predicate computes the weight of a functor and the set of arguments
    % of that functor whose sizes should be counted towards the size of the
    % whole term.
    %
    % NOTE: the list of arguments and the list of modes must be the same
    % length.  They must also *not* contain any typeinfo related arguments as
    % this may cause an exception to be thrown when using the
    % `--num-data-elems' norm.  (This is because the weight table doesn't keep
    % track of typeinfo related variables - it used to but intervening
    % compiler passes tend to do things to the code in the mean time so the
    % whole lot becomes inconsistent - in the end it's just easier to ignore
    % them). 
    %
:- pred functor_norm(functor_info::in, type_ctor::in, cons_id::in,
    module_info::in, int::out, list(prog_var)::in, list(prog_var)::out,
    list(uni_mode)::in, list(uni_mode)::out) is det.

    % This function computes a lower bound on the weight of a fuctor.  If the
    % lower bound is zero then the weight of that functor is also zero.  If
    % the lower bound is non-zero then there may be no upper bound on the size
    % of the functor.  (And if there were this function wouldn't tell you about
    % it anyhow).
    %
:- func functor_lower_bound(functor_info, type_ctor, cons_id, module_info) 
    = int.
    
    % Succeeds if all values of the given type are zero size (for all norms).
    %
:- pred zero_size_type(mer_type::in, module_info::in) is semidet.

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

:- implementation.

:- import_module check_hlds.inst_match.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.type_util.
:- import_module hlds.hlds_data.
:- import_module libs.compiler_util.
:- import_module libs.options.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.

:- import_module assoc_list.
:- import_module bool.
:- import_module map.
:- import_module require.
:- import_module std_util.
:- import_module string.
:- import_module svmap.

%-----------------------------------------------------------------------------%

% We use semilinear norms (denoted by ||) to compute the sizes of terms.
% These have the form
%
% | f(t1, ... tn) | = weight(f) + sum of | ti |
% where i is an element of a set I, and I is a subset of {1, ... n}
%
% We currently support four kinds of semilinear norms.
% XXX Actually we currently only use three of them.  `use_map/1' is unused.

:- type functor_info
    --->    simple  % All non-constant functors have weight 1,
                    % while constants have weight 0.
                    % Use the size of all subterms (I = {1, ..., n}.

    ;       total   % All functors have weight = arity of the functor.
                    % Use the size of all subterms (I = {1, ..., n}.

    ;       use_map(weight_table)
                    % The weight of each functor is given by the table.
                    % Use the size of all subterms (I = {1, ..., n}.

    ;       use_map_and_args(weight_table).
                    % The weight of each functor is given by the table,
                    % and so is the set of arguments of the functor whose
                    % size should be counted (I is given by the table
                    % entry of the functor).

%-----------------------------------------------------------------------------%

% Calculate the weight to be assigned to each function symbol for the
% use_map and use_map_and_args semilinear norms.
%
% Given a type definition such as
%
% :- type t(Tk) --->    f1(a11, ... a1n1)   where n1 is the arity of f1
%       ;   ...
%       ;   fm(am1, ... amnm)   where nm is the arity of fm
%
% we check, for each aij, whether its type is recursive (i.e. it is t with
% type variable arguments that are a permutation of Tk). The weight info
% we compute for each functor will have a boolean list that has a `yes'
% for each recursive argument and a `no' for each nonrecursive argument.
% The weight to be assigned to the functor is the number of nonrecursive
% arguments, except that we assign a weight of at least 1 to all functors
% which are not constants.

:- type weight_table == map(pair(type_ctor, cons_id), weight_info).

:- type weight_info ---> weight(int, list(bool)).

:- pred find_weights(module_info::in, weight_table::out) is det.

find_weights(ModuleInfo, Weights) :-
    module_info_get_type_table(ModuleInfo, TypeTable),
    map.to_assoc_list(TypeTable, TypeList),
    map.init(Weights0),
    list.foldl(find_weights_for_type, TypeList, Weights0, Weights).

:- pred find_weights_for_type(pair(type_ctor, hlds_type_defn)::in,
    weight_table::in, weight_table::out) is det.

find_weights_for_type(TypeCtor - TypeDefn, !Weights) :-
    hlds_data.get_type_defn_body(TypeDefn, TypeBody),
    (
        Constructors = TypeBody ^ du_type_ctors,
        hlds_data.get_type_defn_tparams(TypeDefn, TypeParams),
        list.foldl(find_weights_for_cons(TypeCtor, TypeParams),
            Constructors, !Weights)
    ;
        % This type does not introduce any functors
        TypeBody = eqv_type(_)
    ;
        % This type may introduce some functors,
        % but we will never see them in this analysis
        TypeBody = abstract_type(_)
    ;
        % This type does not introduce any functors
        TypeBody = foreign_type(_)
    ;
        % This type does not introduce any functors
        TypeBody = solver_type(_, _)
    ).

:- pred find_weights_for_cons(type_ctor::in, list(type_param)::in,
    constructor::in, weight_table::in, weight_table::out) is det.

% For existentially typed data items the compiler may insert some typeinfo
% related arguments into the functor.  We ignore these arguments when
% calculating the weight of a functor and we do not include them in the list
% of counted arguments.

find_weights_for_cons(TypeCtor, Params, Ctor, !Weights) :-
    Ctor = ctor(_ExistQVars, _Constraints, SymName, Args),
    list.length(Args, Arity),
    ( Arity > 0 ->
        find_and_count_nonrec_args(Args, TypeCtor, Params,
            NumNonRec, ArgInfos0),
        ( NumNonRec = 0 ->
            Weight = 1,
            list.duplicate(Arity, yes, ArgInfos)
        ;
            Weight = NumNonRec,
            ArgInfos = ArgInfos0
        ),
        WeightInfo = weight(Weight, ArgInfos)
    ;
        WeightInfo = weight(0, [])
    ),
    ConsId = cons(SymName, Arity),
    svmap.det_insert(TypeCtor - ConsId, WeightInfo, !Weights).

:- pred find_weights_for_tuple(arity::in, weight_info::out) is det.

find_weights_for_tuple(Arity, weight(Weight, ArgInfos)) :-
    % None of the tuple arguments are recursive.
    Weight = Arity,
    list.duplicate(Arity, yes, ArgInfos).

:- pred find_and_count_nonrec_args(list(constructor_arg)::in,
    type_ctor::in, list(type_param)::in,
    int::out, list(bool)::out) is det.

find_and_count_nonrec_args([], _, _, 0, []).
find_and_count_nonrec_args([Arg | Args], Id, Params, NonRecArgs, ArgInfo) :-
    find_and_count_nonrec_args(Args, Id, Params, NonRecArgs0, ArgInfo0),
    ( is_arg_recursive(Arg, Id, Params) ->
        NonRecArgs = NonRecArgs0,
        ArgInfo = [yes | ArgInfo0]
    ;
        NonRecArgs = NonRecArgs0 + 1,
        ArgInfo = [no | ArgInfo0]
    ).

:- pred is_arg_recursive(constructor_arg::in, type_ctor::in,
    list(type_param)::in) is semidet.

is_arg_recursive(Arg, TypeCtor, Params) :-
    Arg = _Name - ArgType,
    type_to_ctor_and_args(ArgType, ArgTypeCtor, ArgTypeArgs),
    TypeCtor = ArgTypeCtor,
    prog_type.type_list_to_var_list(ArgTypeArgs, ArgTypeParams),
    list.perm(Params, ArgTypeParams).

:- pred search_weight_table(weight_table::in, type_ctor::in, cons_id::in,
    weight_info::out) is semidet.

search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo) :-
    ( map.search(WeightMap, TypeCtor - ConsId, WeightInfo0) ->
        WeightInfo = WeightInfo0
    ; type_ctor_is_tuple(TypeCtor) ->
        TypeCtor = _ - Arity,
        find_weights_for_tuple(Arity, WeightInfo)
    ;
        fail
    ).

%-----------------------------------------------------------------------------%

set_functor_info(total, _ModuleInfo) = total.
set_functor_info(simple, _ModuleInfo) = simple.
set_functor_info(num_data_elems, ModuleInfo) = use_map_and_args(WeightMap) :-
    find_weights(ModuleInfo, WeightMap).
set_functor_info(size_data_elems, ModuleInfo) = use_map(WeightMap) :-
    find_weights(ModuleInfo, WeightMap).

%-----------------------------------------------------------------------------%

% Although the module info is not used in any of these norms, it could
% be needed for other norms, so it should not be removed.

functor_norm(simple, _, ConsId, _, Int, !Args, !Modes) :-
    (
        ConsId = cons(_, Arity),
        Arity \= 0
    ->
        Int = 1
    ;
        Int = 0
    ).
functor_norm(total, _, ConsId, _, Int, !Args, !Modes) :-
    ( ConsId = cons(_, Arity) ->
        Int = Arity
    ;
        Int = 0
    ).
functor_norm(use_map(WeightMap), TypeCtor, ConsId, _, Int, !Args, !Modes) :-
    ( search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo) ->
        WeightInfo = weight(Int, _)
    ;
        Int = 0
    ).
functor_norm(use_map_and_args(WeightMap), TypeCtor, ConsId, _, Int, !Args,
        !Modes) :-
    ( search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo) ->
        WeightInfo = weight(Int, UseArgList),
        (
            functor_norm_filter_args(UseArgList, !Args, !Modes)
        ->
            true
        ;
            unexpected(this_file,
                "Unmatched lists in functor_norm_filter_args.")
        )
    ;
        Int = 0
    ).

    % This predicate will fail if the length of the input lists are not
    % matched.
    %
:- pred functor_norm_filter_args(list(bool)::in, list(prog_var)::in,
    list(prog_var)::out, list(uni_mode)::in, list(uni_mode)::out)
    is semidet.

functor_norm_filter_args([], [], [], [], []).
functor_norm_filter_args([yes | Bools], [Arg0 | Args0], [Arg0 | Args],
        [Mode0 | Modes0], [Mode0 | Modes]) :-
    functor_norm_filter_args(Bools, Args0, Args, Modes0, Modes).
functor_norm_filter_args([no | Bools], [_Arg0 | Args0], Args,
        [_Mode0 | Modes0], Modes) :-
    functor_norm_filter_args(Bools, Args0, Args, Modes0, Modes).

%-----------------------------------------------------------------------------%

functor_lower_bound(simple, _, ConsId, _) =
    ( if ConsId = cons(_, Arity), Arity \= 0 then 1 else 0).
functor_lower_bound(total, _, ConsId, _) =
    ( if ConsId = cons(_, Arity) then Arity else 0 ).
functor_lower_bound(use_map(WeightMap), TypeCtor, ConsId, _) = Weight :-
    ( if    search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo)
      then  WeightInfo = weight(Weight, _)
      else  Weight = 0
    ).
functor_lower_bound(use_map_and_args(WeightMap), TypeCtor, ConsId, _) 
        = Weight :-
    ( if    search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo)
      then  WeightInfo = weight(Weight, _)
      else  Weight = 0
    ).

%-----------------------------------------------------------------------------%

zero_size_type(Type, Module) :-
    type_util.classify_type(Module, Type) = TypeCategory,
    zero_size_type_category(TypeCategory, yes).

:- pred zero_size_type_category(type_category::in, bool::out) is det.

zero_size_type_category(type_cat_int, yes).
zero_size_type_category(type_cat_char, yes).
zero_size_type_category(type_cat_string, yes).
zero_size_type_category(type_cat_float, yes).
zero_size_type_category(type_cat_void, yes).
zero_size_type_category(type_cat_type_info, yes).
zero_size_type_category(type_cat_type_ctor_info, yes).
zero_size_type_category(type_cat_typeclass_info, yes).
zero_size_type_category(type_cat_base_typeclass_info, yes).
zero_size_type_category(type_cat_higher_order, yes).
zero_size_type_category(type_cat_tuple, no).
zero_size_type_category(type_cat_enum, yes).
zero_size_type_category(type_cat_dummy, yes).
zero_size_type_category(type_cat_variable, no).
zero_size_type_category(type_cat_user_ctor, no).

%-----------------------------------------------------------------------------%

:- func this_file = string.

this_file = "term_norm.m".

%-----------------------------------------------------------------------------%
:- end_module term_norm.
%-----------------------------------------------------------------------------%