mercury/compiler/shapes.m

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
% File: shapes.nl
% Main author: trd 
%
% This file prepares the shape information that is required by each
% module.
%
% shapes__request_shape_number is called during code generation
% and gathers information about the shape if it isn't already within the
% table.
%
% Different shapes and shape numbers are generated for every type which 
% is different. Since list(foo) and list(bar) have different types, they 
% will have seperate shapes. Parameteric polymorphism, such as list(T), 
% is treated seperately also, but a normal shape description is not given
% to the T, but it is stored as a type variable, so it can be treated as 
% a list, up until the point where garbage collection needs to know what
% it is a list of, then the gc system can find out (at runtime) what it
% needs to know. 
%
% When a closure , eg pred(....) is passed a special shape is created for it
% so its arguments can be determined at runtime.
%
% Abstract shapes have their type infomation stored in a special format,
% and they can be replaced by a normal shape at link time, when we know what
% the implementation of the abstract shape is. For this to work properly, 
% we need a table mapping abstract types (without any arguments) that are 
% exported, to the definition of that type's shape (yet to be done).
% Then at link time, all abstract types which are encountered can be 
% replaced by the implementation of that shape.
%
% XXX Rely on 32bit architecture due to 4 bit tags - better to use a list.
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

:- module shapes.
:- interface.

:- import_module int, map, std_util, list, hlds, require,
		 prog_io, type_util, string, term.

:- type tagged_num	==	pair(shape_num,tag_type).
:- type tag_type	--->    const; simple; complicated.

:- type shape_list	==	list(pair(shape_num, tagged_num)).
:- type length_list	==	list(int).
:- type contents_list	==	list(int).

:- pred shapes__init_shape_table(shape_table).
:- mode shapes__init_shape_table(out) is det.

:- pred shapes__request_shape_number(shape_id, type_table, shape_table, 
			shape_table, shape_num).
:- mode shapes__request_shape_number(in, in, in, out, out) is det.

:- pred shapes__construct_shape_lists(shape_table, shape_list, 
		length_list, contents_list). 
:- mode shapes__construct_shape_lists(in, out, out, out) is det. 

:- pred shapes__do_abstract_exports(module_info, module_info).
:- mode shapes__do_abstract_exports(in, out) is det.

:- implementation.

:- type bit_number --->  bit_zero; bit_one; bit_two; bit_three.

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
% PUBLIC PREDICATES: 
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

%-----------------------------------------------------------------------------%
% Initialization is done rather simply.
% XXX We manually insert some non-standard builtin types. This may cause
% problems if the types are redefined in some way... These and other
% low numbered cases need to be treated specially at runtime...
% Note : still have to deal with succip etc.
%-----------------------------------------------------------------------------%
shapes__init_shape_table((S_Tab_Out - S_Num)) :-
	map__init(S_Tab0),
	Const = quad(constant, constant, constant, constant),
	term__context_init(TermContext),
	(
		map__insert(S_Tab0, term__functor(term__atom("string"), [],
			TermContext) - ground, 0 - Const, S_Tab1),
		map__insert(S_Tab1, term__functor(term__atom("float"), [],
			TermContext) - ground, 1 - Const, S_Tab2),
		map__insert(S_Tab2, term__functor(term__atom("int"), [],
			TermContext) - ground, 2 - Const, S_Tab3),
		map__insert(S_Tab3, term__functor(term__atom("character"), [],
			TermContext) - ground, 3 - Const, S_Tab4) 
	-> 
		S_Num = 4,
		S_Tab_Out = S_Tab4
	;
		error("shapes: init_shape_table: initialization failure") 
	).

%-----------------------------------------------------------------------------%
% Creation of the shape table allows shapes to be uniquely numbered.
% Later, this information will be used to create the shape lists.
% We only deal well with ground shapes, partial insts and free insts
% may need some modification.
%-----------------------------------------------------------------------------%
shapes__request_shape_number(ShapeId0, Type_Table, S_Tab0 - Next_S_Num0,
				S_Tab - NextNum, S_Num) :-
	shapes__replace_context(ShapeId0, ShapeId),
	(
		map__contains(S_Tab0, ShapeId)  
	-> 
		map__lookup(S_Tab0, ShapeId, (S_Num - _)),
		S_Tab = S_Tab0,
		NextNum = Next_S_Num0
	;
		Next_S_Num1 is Next_S_Num0 + 1,
		S_Num is Next_S_Num0 + 1,
	% Avoid infinite recursion by inserting a 'dummy' shape
	% so that if the shape is self-referential, it doesn't
	% cause trouble.
		map__set(S_Tab0, ShapeId, Next_S_Num1 - quad(constant, 
			constant, constant, constant), S_Tab1),
		shapes__create_shape(Type_Table, ShapeId, Shape, 
			S_Tab1 - Next_S_Num1, S_Tab2 - NextNum),
		map__set(S_Tab2, ShapeId, (Next_S_Num1 - Shape), S_Tab) 
	).
%-----------------------------------------------------------------------------%
% To actually construct the flat lists that are nearly ready for output
% into a file. 
%-----------------------------------------------------------------------------%
shapes__construct_shape_lists(S_Tab, S_List, L_List, C_List) :-
	S_Tab = Shape_Tab - _,
	map__values(Shape_Tab, Temp_List),
	list__sort(Temp_List, TS_List),
	shapes__make_shape_tag_list(TS_List, Tag_List),
	shapes__construct_lists(Tag_List, S_Tab, S_List, L_List, _,
		C_List, _).

shapes__do_abstract_exports(HLDS0, HLDS) :-
	module_info_types(HLDS0, Types),
	module_info_shape_info(HLDS0, Shape_Info),
	Shape_Info = shape_info(Shapes, Abs_Exports),
	map__to_assoc_list(Abs_Exports, Export_List),
	shapes__add_shape_numbers(Export_List, Types, Shapes, Shapes2,
			 Export_List2),
	map__from_assoc_list(Export_List2, Abs_Exports2),
	Shape_Info_2 = shape_info(Shapes2, Abs_Exports2),
	module_info_set_shape_info(HLDS0, Shape_Info_2, HLDS).

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
% LOCAL PREDICATES: 
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

:- pred shapes__add_shape_numbers(assoc_list(type_id, maybe_shape_num),
				type_table, shape_table, shape_table, 
				assoc_list(type_id, maybe_shape_num)).
:- mode shapes__add_shape_numbers(in, in, in, out, out) is det.

shapes__add_shape_numbers([], _, S, S, []).
shapes__add_shape_numbers([T - S | Ts] , Types, S0, S2, [ N | Ns] ) :-
	shapes__add_shape_numbers(Ts, Types, S0, S1, Ns),
	(
		S = yes(_)
	->
		N = T - S,
		S2 = S1
	;	
		S = no(Type)
	->
		shapes__request_shape_number(Type - ground, Types,  
 			S1, S2, S_Num),
		N = T - yes(S_Num)
	;
		error("shapes__add_shape_numbers: Unreachable case reached!") 
	).
	

%-----------------------------------------------------------------------------%
% We want to 'remove' the context of the types that we lookup and deal with
% in the shape table.
%-----------------------------------------------------------------------------%
:- pred shapes__replace_context(shape_id, shape_id).
:- mode shapes__replace_context(in, out) is det.
shapes__replace_context(Type - Inst, NewType - Inst) :-
	shapes__replace_all_contexts([Type], NewTypes),
	(
		NewTypes = [ _Type | [] ]
	->
		NewTypes = [ NewType | _ ]
	;
		error("shapes__replace_context - empty list returned")
	).
	
%-----------------------------------------------------------------------------%
% Want to also remove all type argument contexts, recursively. 
%-----------------------------------------------------------------------------%
:- pred shapes__replace_all_contexts(list(type), list(type)).
:- mode shapes__replace_all_contexts(in, out) is det.
shapes__replace_all_contexts([], []).
shapes__replace_all_contexts([Type | TRest], [ NewType | NewRest ]) :-
	(
		Type = term__functor(C, Ts, _)
	->
		shapes__replace_all_contexts(Ts, Ns),
		term__context_init(Init),
		NewType = term__functor(C, Ns, Init) 
	;
		NewType = Type
	),
	shapes__replace_all_contexts(TRest, NewRest).

%-----------------------------------------------------------------------------%
% To create each shape, we want to group the types on bit tags, eg all
% those with tag 0 are represented by the first part of the quad, all
% those with tag 1 are represented by the second part etc...
%-----------------------------------------------------------------------------%
:- pred shapes__tag_match(bit_number, int).
:- mode shapes__tag_match(in, in) is semidet.

shapes__tag_match(bit_zero, 0).
shapes__tag_match(bit_one, 1).
shapes__tag_match(bit_two, 2).
shapes__tag_match(bit_three, 3).

%-----------------------------------------------------------------------------%
% Create a shape (the structural information of the shape).
%-----------------------------------------------------------------------------%
:- pred shapes__create_shape(type_table, shape_id, shape, shape_table, 
				shape_table). 
:- mode shapes__create_shape(in, in, out, in, out) is det.

shapes__create_shape(Type_Tab, Shape_Id, Shape, S_Tab0, S_Tab) :-
	Shape_Id = Type - _Inst,
	(
		type_to_type_id(Type, Type_Id, TypeArgs) 
	->
		shapes__create_shape_2(Type_Tab, Type, Type_Id, TypeArgs,
				Shape, S_Tab0, S_Tab)
	;
	%% XXX should really check if it is a type variable first.
		Shape = polymorphic(Type),
		S_Tab = S_Tab0
	).

:- pred shapes__create_shape_2(type_table, type, type_id, list(type), shape,
					shape_table, shape_table).
:- mode shapes__create_shape_2(in, in, in, in, out, in, out) is det.

shapes__create_shape_2(Type_Tab, Type, Type_Id, TypeArgs, Shape, 
				S_Tab0, S_Tab) :-
	(
		map__search(Type_Tab, Type_Id, Hlds_Type)
	->
		(
			Hlds_Type = hlds__type_defn(_TypeVarSet, TypeParams,
				du_type(Ctors0, TagVals, _), _, _) 
		->
			term__term_list_to_var_list(TypeParams, TypeParamVars),
			map__from_corresponding_lists(TypeParamVars, TypeArgs,
				TypeSubstitution),
			apply_to_ctors(Ctors0, TypeSubstitution, Ctors),
			
			Shape = quad(A,B,C,D),
			shapes__create_shapeA(Type_Id, Ctors, TagVals,
				bit_zero, A, Type_Tab, S_Tab0, S_Tab1),
			shapes__create_shapeA(Type_Id, Ctors, TagVals,
		 		bit_one, B, Type_Tab, S_Tab1, S_Tab2),
			shapes__create_shapeA(Type_Id, Ctors, TagVals,
		 		bit_two, C, Type_Tab, S_Tab2, S_Tab3),
			shapes__create_shapeA(Type_Id, Ctors, TagVals,
				bit_three, D, Type_Tab, S_Tab3, S_Tab) 
		;
			Hlds_Type = hlds__type_defn(_, _, abstract_type, _, _) 
		% An abstract type that is imported from elsewhere.
		% Later we find the real definition.
		->
			Shape = abstract(Type),
			S_Tab = S_Tab0
		;
			Hlds_Type = hlds__type_defn(_, _, eqv_type(ET), _, _)
		% The case where an abstract type is equivalent to another
 		% abstract type...
		->
			shapes__replace_context(ET - ground, EqvType - _),
			Shape = abstract(EqvType),
			S_Tab = S_Tab0
		;
			error("shapes__create_shape_2: unknown type")
		)
	;
		Type = term__functor(term__atom("pred"), _Vars, _Context) 
	->
		S_Tab = S_Tab0,
		Shape = closure(Type) 
	;
		error("shapes__create_shape_2: not in type table")
	).

:- pred apply_to_ctors(list(constructor), tsubst, list(constructor)).
:- mode apply_to_ctors(in, in, out) is det.

apply_to_ctors([], _, []).
apply_to_ctors([Ctor0 | Ctors0], Subst, [Ctor | Ctors]) :-
	Ctor0 = SymName - ArgTypes0,
	term__apply_substitution_to_list(ArgTypes0, Subst, ArgTypes),
	Ctor = SymName - ArgTypes,
	apply_to_ctors(Ctors0, Subst, Ctors).

%-----------------------------------------------------------------------------%
% We pass seperate the head from the rest as we are going to want to
% match it against many cases.
% We traverse the list until we come to a case that matches out Type_Id, 
% and the tag bit we are interested in. If there are none, it is an unused
% tag and we call it constant.
%-----------------------------------------------------------------------------%
:- pred shapes__create_shapeA(type_id, list(constructor), cons_tag_values,
		bit_number, shape_tag, type_table, shape_table, shape_table).
:- mode shapes__create_shapeA(in, in, in, in, out, in, in, out) is det.

shapes__create_shapeA(_, [], _, _, constant, _, S_Tab, S_Tab).
shapes__create_shapeA(Type_Id, [ Ctor | Rest ] , TagVals, Bits, A, 
			Type_Table, S_Tab0, S_Tab) :-
	Ctor = Symname - Args,
	shapes__make_cons_id(Symname, Args, C_Id),
	map__lookup(TagVals, C_Id, C_Tag), 
	(
		C_Tag = string_constant(_)
	->
		A = constant,
		S_Tab = S_Tab0
	;
		C_Tag = float_constant(_) 
	->
		A = constant,
		S_Tab = S_Tab0
	;
		C_Tag = int_constant(_) 
	->
		A = constant,
		S_Tab = S_Tab0
	;
		C_Tag = address_constant(_, _) 
	->
		A = constant,
		S_Tab = S_Tab0
	;	
		C_Tag = pred_closure_tag(_, _) 
	->
		A = constant,
		S_Tab = S_Tab0
	;	
		C_Tag = simple_tag(X),
		shapes__tag_match(Bits, X) 
	->
		shapes__replace_all_contexts(Args, NewArgs),
		shapes__lookup_simple_info(NewArgs, Shapes_Ids, 
					Type_Table, S_Tab0, S_Tab),
		A = simple(Shapes_Ids) 
	;
		C_Tag = complicated_tag(X, Y),
		shapes__tag_match(Bits, X) 
	->
		shapes__lookup_complicated_info( [Ctor | Rest], TagVals, 
			Bits, Ls, Type_Table, S_Tab0, S_Tab),
		A = complicated(Ls)
	;
		C_Tag = complicated_constant_tag(X, Y),
		shapes__tag_match(Bits, X) 
	->
		A = constant,
		S_Tab = S_Tab0
	;
		shapes__create_shapeA(Type_Id, Rest, TagVals, Bits, A,
					Type_Table, S_Tab0, S_Tab)
		% Where nothing matches up, go on down the list.
	).


%-----------------------------------------------------------------------------%
% Want to find the list of shape_ids that are arguments to the simple 
% tagged type.
%-----------------------------------------------------------------------------%
:- pred shapes__lookup_simple_info(list(type), list(pair(shape_num, shape_id)), 
		type_table, shape_table, shape_table).
:- mode shapes__lookup_simple_info(in, out, in, in, out) is det.

shapes__lookup_simple_info([], [], _, S_Tab, S_Tab).
shapes__lookup_simple_info([ Arg | Args], [ S_Num - S | ShapeIds],
				Type_Table, S_Tab0, S_Tab) :-
	S = Arg - ground,
        shapes__request_shape_number(S, Type_Table, S_Tab0, S_Tab1, S_Num),
	shapes__lookup_simple_info(Args, ShapeIds, Type_Table, S_Tab1, S_Tab).

%-----------------------------------------------------------------------------%
% Since complicated tags are shared by many types, we look up
% all the types that shape, and find all their arguments, and return
% it as a list of lists. Fortunately, this is just a case of calling
% shapes__lookup_simple_info multiple times. 
%-----------------------------------------------------------------------------%
:- pred shapes__lookup_complicated_info(list(constructor), cons_tag_values,
		bit_number, list(list(pair(shape_num, shape_id))), type_table, 
		shape_table, shape_table).
:- mode shapes__lookup_complicated_info(in, in, in, out, in, in, out) is det.

shapes__lookup_complicated_info([], _, _, [], _, S_Tab, S_Tab).
shapes__lookup_complicated_info([Ctor | Cs], Tagvals, Bits, [S_Ids | Ss],
				 Type_Table, S_Tab0, S_Tab) :-
	shapes__get_complicated_shapeids(Ctor, Tagvals, Bits, S_Ids,
					Type_Table, S_Tab0, S_Tab1),
	shapes__lookup_complicated_info(Cs, Tagvals, Bits, Ss, 
					Type_Table, S_Tab1, S_Tab).

:- pred shapes__get_complicated_shapeids(constructor, cons_tag_values,
			bit_number, list(pair(shape_num, shape_id)), 
			type_table, shape_table, shape_table).
:- mode shapes__get_complicated_shapeids(in, in, in, out, in, in, out) is det.
shapes__get_complicated_shapeids(Ctor, Tagvals, Bits, S_Ids, 
					Type_Table, S_Tab0, S_Tab) :- 
	Ctor = Symname - Args,
	shapes__make_cons_id(Symname, Args, C_Id),
	map__lookup(Tagvals, C_Id, C_Tag),
	(
		C_Tag = complicated_tag(Primary, _Sec),
		shapes__tag_match(Bits, Primary)
	->
		shapes__replace_all_contexts(Args, NewArgs),
		shapes__lookup_simple_info(NewArgs, S_Ids,  
						Type_Table, S_Tab0, S_Tab) 
	;
		S_Ids = [],
		S_Tab = S_Tab0
	).

%-----------------------------------------------------------------------------%
% From a list of shape_ids, create the list of shape tags and numbers, 
% as we don't really want to be breaking them into quadruples each time.
%-----------------------------------------------------------------------------%
:- pred shapes__make_shape_tag_list(list(pair(shape_num, shape)),  
		list(pair(shape_num, shape_tag))).
:- mode shapes__make_shape_tag_list(in, out) is det.

shapes__make_shape_tag_list([], []).
shapes__make_shape_tag_list([Num - Shape | Ids], ST_list) :-
	shapes__make_shape_tag_list(Ids, Rest),
	(
		Shape = quad(A,B,C,D)
	->
		ST_list = [ Num - A | [ Num - B | 
				[ Num - C | [ Num - D | Rest ]]]]
	;
		error("shapes__make_shape_tag_list : not ready for abstracts, polymorphism, etc")
	).


%-----------------------------------------------------------------------------%
% Our tags are created here.
%-----------------------------------------------------------------------------%
:- pred shapes__make_const_tag(shape_num, tagged_num).
:- mode shapes__make_const_tag(in, out) is det.

:- pred shapes__make_simple_tag(shape_num, tagged_num).
:- mode shapes__make_simple_tag(in, out) is det.

:- pred shapes__make_complicated_tag(shape_num, tagged_num).
:- mode shapes__make_complicated_tag(in, out) is det.

shapes__make_const_tag(X,(X - const)).
shapes__make_simple_tag(X,(X - simple)).
shapes__make_complicated_tag(X,(X - complicated)).

%-----------------------------------------------------------------------------%
% To construct the lists, want the determinism analysis to find this to be
% deterministic, so we take the head of the list off seperately. 
%-----------------------------------------------------------------------------%
:- pred shapes__construct_lists(list(pair(shape_num, shape_tag)), shape_table,
		shape_list, length_list, int,  contents_list, int).
:- mode shapes__construct_lists(in, in, out, out, out, out, out) is det.

shapes__construct_lists([], _N_tab, [], [], 0, [], 0).
shapes__construct_lists([Num - Stag | Rest], N_tab, Ss, Ls, L_Num, Cs, C_Num) :-
	shapes__constr_lists_1(Stag, Num, Rest, N_tab, Ss, Ls, L_Num, 
		Cs, C_Num).

%-----------------------------------------------------------------------------%
% Choose the case and do the appropriate action.
%-----------------------------------------------------------------------------%
:- pred shapes__constr_lists_1(shape_tag, shape_num, 
		list(pair(shape_num, shape_tag)), shape_table, shape_list, 
		length_list, int, contents_list, int).
:- mode shapes__constr_lists_1(in, in, in, in, out, out, out, out, out) is det.

shapes__constr_lists_1(constant, Num, Rest, N_tab, [Num - Const_Tag|Ss],
		  Ls, L_Num, Cs, C_Num) :-
	shapes__construct_lists(Rest, N_tab, Ss, Ls, L_Num, Cs, C_Num),
	shapes__make_const_tag(0,Const_Tag).
shapes__constr_lists_1(simple(S_Ids), Num, I_Rest, N_tab,
		  [Num - Tagged_L_Num | S_Rest], [C_Len | L_Rest], L_Num_New,
		  C_New, C_Num_New) :-
	shapes__construct_lists(I_Rest, N_tab, S_Rest, L_Rest, L_Num,
		C_Rest, C_Num),
	shapes__constr_lists_3(S_Ids, N_tab, C_Rest, C_New, C_Len),
	C_Num_New is C_Num + C_Len,
	L_Num_New is L_Num + 1,
	shapes__make_simple_tag(L_Num,Tagged_L_Num).
shapes__constr_lists_1(complicated(S_Id_List), Num, I_Rest, N_tab, 
		[Num - Tagged_L_Num | S_Rest], L_New, L_Num_New,
		 C_New, C_Num_New) :-
	shapes__construct_lists(I_Rest, N_tab, S_Rest, L_Rest, L_Num,
		C_Rest, C_Num),
	list__reverse(S_Id_List, Rev_S_Id_List),
% Want to reverse, so they end up in an indexable format for easy C indexing.
	shapes__constr_lists_2(Rev_S_Id_List, N_tab, L_Rest, L_New, L_Num, 
		L_Num_New, C_Rest, C_New, C_Num, C_Num_New),
	shapes__make_complicated_tag(L_Num, Tagged_L_Num).

%-----------------------------------------------------------------------------%
% In complicated shape_tags we want to basically do a simple tag 
% case multiple times. 
%-----------------------------------------------------------------------------%
:- pred shapes__constr_lists_2(list(list(pair(shape_num, shape_id))), shape_table, 
 	       length_list, length_list, int, int, contents_list,
	       contents_list, int, int).
:- mode shapes__constr_lists_2(in, in, in, out, in, out, in, out,
		in, out) is det.
shapes__constr_lists_2([], _N_tab, Ls, Ls, L_Num, L_Num, Cs, Cs, C_Num, C_Num).
shapes__constr_lists_2([S_Ids | Rest], N_tab, Ls0, Ls2, L_Num0, L_Num2, Cs0, Cs2,
		C_Num0, C_Num2) :-
        shapes__constr_lists_2(Rest, N_tab, Ls0, Ls1, L_Num0, L_Num1, 
		Cs0, Cs1, C_Num0, C_Num1),
	shapes__constr_lists_3(S_Ids,  N_tab, Cs1, Cs2, C_Len),
        C_Num2 is C_Num1 + C_Len,
	L_Num2 is L_Num1 + 1,
	Ls2 = [C_Len | Ls1 ].

%-----------------------------------------------------------------------------%
% The simple case - put the shape numbers into the contents table.
%-----------------------------------------------------------------------------%
:- pred shapes__constr_lists_3(list(pair(shape_num, shape_id)), shape_table,
	       contents_list, contents_list, int).
:- mode shapes__constr_lists_3(in, in, in, out, out) is det.

% XXX Might not even need the shape table down here now!

shapes__constr_lists_3([], _S_tab, Cs_Old, Cs_Old, 0).
shapes__constr_lists_3([Shape_Number - _ | S_Ids], S_tab, Cs_Old,
		[Shape_Number | Cs], C_Len_New) :-
	shapes__constr_lists_3(S_Ids, S_tab, Cs_Old, Cs, C_Len),
	C_Len_New is C_Len + 1.

%-----------------------------------------------------------------------------%
% An interface to make_cons_id. 
%-----------------------------------------------------------------------------%
:- pred shapes__make_cons_id(sym_name, list(type), cons_id).
:- mode shapes__make_cons_id(in, in, out) is det.
shapes__make_cons_id(Sym, Typelist, C_Id) :- 
	make_cons_id(Sym, Typelist, unqualified("X") - 0, C_Id).