[m-dev.] for review: passing boxed floats to pragma C code

[Zoltan Somogyi]

For review by anyone.

Add support for passing boxed float arguments to pragma C codes, i.e. as Words.
This requires the C code to call word_to_float on inputs and float_to_word
on outputs as necessary, but also allows C code to store *already boxed*
floats in data structures, and return them to C code without the memory
allocation inherent in reboxing. When this change has been bootstrapped,
I will modify the routines in mercury_tabling.c and private_builtin.m
that save and restore floats to use this new facility.

compiler/prog_data.m:
	Add an extra kind of attribute to pragma_c_code goals: the
	pragma_float_format, with two values: pragma_unboxed_float and
	pragma_boxed_float. With the former, which is the default, float
	arguments are passed to and from pragma C code as type Float, as now.
	With the latter, they are passed in boxed form, as type Word.

compiler/prog_io_pragma.m:
	Parse the new attribute.

compiler/llds.m:
	Add an extra parameter to pragma_c instructions that records the
	pragma_float_format.

compiler/llds_out.m:
	When the pragma_float_format is pragma_boxed_float, don't convert float
	arguments of pragmas from or to the internal boxed representation.

compiler/pragma_c_gen.m:
compiler/code_gen.m:
	Transmit the float format from the HLDS to the LLDS. In code_gen.m,
	also fix a bug: the may_call_mercury attribute was being ignored.

compiler/*.m:
	In other files, lots of minor changes to conform to the changes
	in the data structures.

Zoltan.

cvs diff: Diffing .
Index: code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_gen.m,v
retrieving revision 1.71
diff -u -b -r1.71 code_gen.m
--- code_gen.m	1999/12/14 04:52:31	1.71
+++ code_gen.m	1999/12/28 00:10:29
@@ -174,8 +174,10 @@
 			maybe(int),	% Slot number of succip if succip is
 					% present in a general slot.
 
-			bool		% Is this the frame of a model_non
+			maybe(pair(may_call_mercury, pragma_float_format))
+					% Is this the frame of a model_non
 					% proc defined via pragma C code?
+					% If so, give its relevant attributes.
 		).
 
 %---------------------------------------------------------------------------%
@@ -569,7 +571,8 @@
 		{ code_info__resume_point_stack_addr(OutsideResumePoint,
 			OutsideResumeAddress) },
 		(
-			{ Goal = pragma_c_code(_,_,_,_,_,_, PragmaCode) - _},
+			{ Goal = pragma_c_code(Attributes, _,_,_,_,_,
+				PragmaCode) - _},
 			{ PragmaCode = nondet(Fields, FieldsContext,
 				_,_,_,_,_,_,_) }
 		->
@@ -582,14 +585,17 @@
 			{ DefineComponents = [pragma_c_raw_code(DefineStr)] },
 			{ NondetFrameInfo = ordinary_frame(PushMsg, TotalSlots,
 				yes(Struct)) },
+			{ may_call_mercury(Attributes, MayCallMercury) },
+			{ pragma_float_format(Attributes, FloatFormat) },
 			{ AllocCode = node([
 				mkframe(NondetFrameInfo, OutsideResumeAddress)
 					- "Allocate stack frame",
 				pragma_c([], DefineComponents,
-					will_not_call_mercury, no, no, no)
+					MayCallMercury, FloatFormat,
+					no, no, no)
 					- ""
 			]) },
-			{ NondetPragma = yes }
+			{ NondetPragma = yes(MayCallMercury - FloatFormat) }
 		;
 			{ NondetFrameInfo = ordinary_frame(PushMsg, TotalSlots,
 				no) },
@@ -668,12 +674,12 @@
 		comment("End of procedure epilogue") - ""
 	]) },
 	{ FrameInfo = frame(TotalSlots, MaybeSuccipSlot, NondetPragma) },
-	( { NondetPragma = yes } ->
+	( { NondetPragma = yes(MayCallMercury - FloatFormat) } ->
 		{ UndefStr = "#undef\tMR_ORDINARY_SLOTS\n" },
 		{ UndefComponents = [pragma_c_raw_code(UndefStr)] },
 		{ UndefCode = node([
 			pragma_c([], UndefComponents,
-				will_not_call_mercury, no, no, no)
+				MayCallMercury, FloatFormat, no, no, no)
 				- ""
 		]) },
 		{ RestoreDeallocCode = empty },	% always empty for nondet code
Index: code_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_info.m,v
retrieving revision 1.246
diff -u -b -r1.246 code_info.m
--- code_info.m	1999/12/14 04:52:33	1.246
+++ code_info.m	1999/12/27 23:43:24
@@ -1802,7 +1802,7 @@
 			],
 			MarkCode = node([
 				pragma_c([], Components, will_not_call_mercury,
-					no, no, no) - ""
+					pragma_boxed_float, no, no, no) - ""
 			])
 		;
 			UseMinimalModel = no,
@@ -1880,7 +1880,7 @@
 			],
 			CutCode = node([
 				pragma_c([], Components, will_not_call_mercury,
-					no, no, no)
+					pragma_boxed_float, no, no, no)
 					- "commit for temp frame hijack"
 			])
 		;
Index: dupelim.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dupelim.m,v
retrieving revision 1.44
diff -u -b -r1.44 dupelim.m
--- dupelim.m	1999/11/15 00:42:21	1.44
+++ dupelim.m	1999/12/27 23:44:24
@@ -115,7 +115,7 @@
 	),
 	AddPragmaReferredLabels = lambda(
 		[Instr::in, FoldFixed0::in, FoldFixed::out] is det, (
-		( Instr = pragma_c(_, _, _, yes(FixedLabel), _, _) - _ ->
+		( Instr = pragma_c(_, _, _, _, yes(FixedLabel), _, _) - _ ->
 			set__insert(FoldFixed0, FixedLabel, FoldFixed)
 		;
 			FoldFixed = FoldFixed0
@@ -367,7 +367,7 @@
 		standardize_lval(Lval1, Lval),
 		Instr = join_and_continue(Lval, N)
 	;
-		Instr1 = pragma_c(_, _, _, _, _, _),
+		Instr1 = pragma_c(_, _, _, _, _, _, _),
 		Instr = Instr1
 	).
 
@@ -636,7 +636,7 @@
 		Instr2 = Instr1,
 		Instr = Instr1
 	;
-		Instr1 = pragma_c(_, _, _, _, _, _),
+		Instr1 = pragma_c(_, _, _, _, _, _, _),
 		Instr2 = Instr1,
 		Instr = Instr1
 	).
Index: frameopt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/frameopt.m,v
retrieving revision 1.74
diff -u -b -r1.74 frameopt.m
--- frameopt.m	1999/11/15 00:42:23	1.74
+++ frameopt.m	1999/12/27 23:44:35
@@ -539,7 +539,7 @@
 				Uinstr = c_code(_)
 			;
 				Uinstr = pragma_c(_, _, MayCallMercury,
-					MaybeFixed, _, NeedStack),
+					_, MaybeFixed, _, NeedStack),
 				(
 					MayCallMercury = may_call_mercury
 				;
@@ -668,7 +668,7 @@
 			Uinstr = call(_, _, _, _, _)
 		;
 			% Only may_call_mercury pragma_c's can clobber succip.
-			Uinstr = pragma_c(_, _, may_call_mercury, _, _, _)
+			Uinstr = pragma_c(_, _, may_call_mercury, _, _, _, _)
 		)
 	->
 		CanClobberSuccip = yes
Index: livemap.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/livemap.m,v
retrieving revision 1.45
diff -u -b -r1.45 livemap.m
--- livemap.m	1999/11/15 00:42:28	1.45
+++ livemap.m	1999/12/27 23:44:41
@@ -356,7 +356,7 @@
 		DontValueNumber = yes
 	;
 		% XXX we shouldn't just give up here
-		Uinstr0 = pragma_c(_, _, _, _, _, _),
+		Uinstr0 = pragma_c(_, _, _, _, _, _, _),
 		Livemap = Livemap0,
 		Livevals = Livevals0,
 		Instrs = Instrs0,
Index: llds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.255
diff -u -b -r1.255 llds.m
--- llds.m	1999/12/16 11:36:37	1.255
+++ llds.m	1999/12/27 23:13:55
@@ -342,8 +342,8 @@
 			% Decrement the det stack pointer.
 
 	;	pragma_c(list(pragma_c_decl), list(pragma_c_component),
-				may_call_mercury, maybe(label), maybe(label),
-				bool)
+				may_call_mercury, pragma_float_format,
+				maybe(label), maybe(label), bool)
 			% The first argument says what local variable
 			% declarations are required for the following
 			% components, which in turn can specify how
@@ -361,20 +361,24 @@
 			% can be performed across pragma_c instructions that
 			% cannot call Mercury.
 			%
+			% The fourth argument says how float arguments
+			% should be passed to and from C code: as floats
+			% for simplicity, or as words for performance.
+			%
 			% Some components in some pragma_c instructions
 			% refer to a Mercury label. If they do, we must
 			% prevent the label from being optimized away.
 			% To make it known to labelopt, we mention it in
-			% the fourth or the fifth arg. The fourth argument
+			% the fifth or the sixth arg. The fifth argument
 			% may give the name of a label whose name is fixed
 			% (e.g. because it embedded in raw C code or because it
 			% has associated an label layout structure), while
-			% the fifth may give the name of a label that can
+			% the sixth may give the name of a label that can
 			% be changed (because it is not mentioned in C code
 			% and has no associated layout structure, being
 			% mentioned only in pragma_c_fail_to components).
 			%
-			% The sixth argument says whether the contents
+			% The last argument says whether the contents
 			% of the pragma C code can refer to stack slots.
 			% User-written shouldn't refer to stack slots,
 			% the question is whether the compiler-generated
Index: llds_common.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_common.m,v
retrieving revision 1.26
diff -u -b -r1.26 llds_common.m
--- llds_common.m	1999/12/14 04:52:45	1.26
+++ llds_common.m	1999/12/27 23:44:48
@@ -259,7 +259,7 @@
 		Instr = Instr0,
 		Info = Info0
 	;
-		Instr0 = pragma_c(_, _, _, _, _, _),
+		Instr0 = pragma_c(_, _, _, _, _, _, _),
 		Instr = Instr0,
 		Info = Info0
 	).
Index: llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.133
diff -u -b -r1.133 llds_out.m
--- llds_out.m	1999/12/16 11:36:39	1.133
+++ llds_out.m	1999/12/27 23:26:32
@@ -1323,7 +1323,8 @@
 	output_rval_decls(Rval, "", "", 0, _, DeclSet0, DeclSet).
 output_instruction_decls(incr_sp(_, _), DeclSet, DeclSet) --> [].
 output_instruction_decls(decr_sp(_), DeclSet, DeclSet) --> [].
-output_instruction_decls(pragma_c(_, Comps, _, _, _, _), DeclSet0, DeclSet) -->
+output_instruction_decls(pragma_c(_, Comps, _, _, _, _, _),
+		DeclSet0, DeclSet) -->
 	output_pragma_c_component_list_decls(Comps, DeclSet0, DeclSet).
 output_instruction_decls(init_sync_term(Lval, _), DeclSet0, DeclSet) -->
 	output_lval_decls(Lval, "", "", 0, _, DeclSet0, DeclSet).
@@ -1648,10 +1649,10 @@
 	io__write_int(N),
 	io__write_string(");\n").
 
-output_instruction(pragma_c(Decls, Components, _, _, _, _), _) -->
+output_instruction(pragma_c(Decls, Components, _, FloatFormat, _, _, _), _) -->
 	io__write_string("\t{\n"),
-	output_pragma_decls(Decls),
-	output_pragma_c_components(Components),
+	output_pragma_decls(Decls, FloatFormat),
+	output_pragma_c_components(Components, FloatFormat),
 	io__write_string("\n\t}\n").
 
 output_instruction(init_sync_term(Lval, N), _) -->
@@ -1683,22 +1684,23 @@
 	io__write_string(");\n").
 
 :- pred output_pragma_c_components(list(pragma_c_component),
+	pragma_float_format, io__state, io__state).
+:- mode output_pragma_c_components(in, in, di, uo) is det.
+
+output_pragma_c_components([], _) --> [].
+output_pragma_c_components([C | Cs], FloatFormat) -->
+	output_pragma_c_component(C, FloatFormat),
+	output_pragma_c_components(Cs, FloatFormat).
+
+:- pred output_pragma_c_component(pragma_c_component, pragma_float_format,
 	io__state, io__state).
-:- mode output_pragma_c_components(in, di, uo) is det.
+:- mode output_pragma_c_component(in, in, di, uo) is det.
 
-output_pragma_c_components([]) --> [].
-output_pragma_c_components([C | Cs]) -->
-	output_pragma_c_component(C),
-	output_pragma_c_components(Cs).
-
-:- pred output_pragma_c_component(pragma_c_component, io__state, io__state).
-:- mode output_pragma_c_component(in, di, uo) is det.
-
-output_pragma_c_component(pragma_c_inputs(Inputs)) -->
-	output_pragma_inputs(Inputs).
-output_pragma_c_component(pragma_c_outputs(Outputs)) -->
-	output_pragma_outputs(Outputs).
-output_pragma_c_component(pragma_c_user_code(MaybeContext, C_Code)) -->
+output_pragma_c_component(pragma_c_inputs(Inputs), FloatFormat) -->
+	output_pragma_inputs(Inputs, FloatFormat).
+output_pragma_c_component(pragma_c_outputs(Outputs), FloatFormat) -->
+	output_pragma_outputs(Outputs, FloatFormat).
+output_pragma_c_component(pragma_c_user_code(MaybeContext, C_Code), _) -->
 	( { C_Code = "" } ->
 		[]
 	;
@@ -1716,39 +1718,47 @@
 			io__write_string(";}\n")
 		)
 	).
-output_pragma_c_component(pragma_c_raw_code(C_Code)) -->
+output_pragma_c_component(pragma_c_raw_code(C_Code), _) -->
 	io__write_string(C_Code).
-output_pragma_c_component(pragma_c_fail_to(Label)) -->
+output_pragma_c_component(pragma_c_fail_to(Label), _) -->
 	io__write_string("if (!r1) GOTO_LABEL("),
 	output_label(Label),
 	io__write_string(");\n").
-output_pragma_c_component(pragma_c_noop) --> [].
+output_pragma_c_component(pragma_c_noop, _) --> [].
 
 	% Output the local variable declarations at the top of the 
 	% pragma_c_code code.
-:- pred output_pragma_decls(list(pragma_c_decl), io__state, io__state).
-:- mode output_pragma_decls(in, di, uo) is det.
+:- pred output_pragma_decls(list(pragma_c_decl), pragma_float_format,
+	io__state, io__state).
+:- mode output_pragma_decls(in, in, di, uo) is det.
 
-output_pragma_decls([]) --> [].
-output_pragma_decls([D|Decls]) -->
+output_pragma_decls([], _) --> [].
+output_pragma_decls([Decl | Decls], FloatFormat) -->
 	(
-		{ D = pragma_c_arg_decl(Type, VarName) },
+		{ Decl = pragma_c_arg_decl(Type, VarName) },
 		% Apart from special cases, the local variables are Words
-		{ export__type_to_type_string(Type, VarType) },
+		{
+			Type = term__functor(term__atom("float"), [], _),
+			FloatFormat = pragma_boxed_float
+		->
+			VarType = "Word"
+		;
+			export__type_to_type_string(Type, VarType)
+		},
 		io__write_string("\t"),
 		io__write_string(VarType),
 		io__write_string("\t"),
 		io__write_string(VarName),
 		io__write_string(";\n")
 	;
-		{ D = pragma_c_struct_ptr_decl(StructTag, VarName) },
+		{ Decl = pragma_c_struct_ptr_decl(StructTag, VarName) },
 		io__write_string("\tstruct "),
 		io__write_string(StructTag),
 		io__write_string("\t*"),
 		io__write_string(VarName),
 		io__write_string(";\n")
 	),
-	output_pragma_decls(Decls).
+	output_pragma_decls(Decls, FloatFormat).
 
 	% Output declarations for any rvals used to initialize the inputs
 :- pred output_pragma_input_rval_decls(list(pragma_c_input), decl_set, decl_set,
@@ -1763,12 +1773,13 @@
 
 	% Output the input variable assignments at the top of the 
 	% pragma_c_code code.
-:- pred output_pragma_inputs(list(pragma_c_input), io__state, io__state).
-:- mode output_pragma_inputs(in, di, uo) is det.
+:- pred output_pragma_inputs(list(pragma_c_input), pragma_float_format,
+	io__state, io__state).
+:- mode output_pragma_inputs(in, in, di, uo) is det.
 
-output_pragma_inputs([]) --> [].
-output_pragma_inputs([I|Inputs]) -->
-	{ I = pragma_c_input(VarName, Type, Rval) },
+output_pragma_inputs([], _) --> [].
+output_pragma_inputs([Input | Inputs], FloatFormat) -->
+	{ Input = pragma_c_input(VarName, Type, Rval) },
 	io__write_string("\t"),
 	io__write_string(VarName),
 	io__write_string(" = "),
@@ -1778,14 +1789,15 @@
 		io__write_string("(String) "),
 		output_rval_as_type(Rval, word)
 	;
-        	{ Type = term__functor(term__atom("float"), [], _) }
+        	{ Type = term__functor(term__atom("float"), [], _) },
+		{ FloatFormat = pragma_unboxed_float }
 	->
 		output_rval_as_type(Rval, float)
 	;
 		output_rval_as_type(Rval, word)
 	),
 	io__write_string(";\n"),
-	output_pragma_inputs(Inputs).
+	output_pragma_inputs(Inputs, FloatFormat).
 
 	% Output declarations for any lvals used for the outputs
 :- pred output_pragma_output_lval_decls(list(pragma_c_output),
@@ -1800,12 +1812,13 @@
 
 	% Output the output variable assignments at the bottom of the
 	% pragma_c_code
-:- pred output_pragma_outputs(list(pragma_c_output), io__state, io__state).
-:- mode output_pragma_outputs(in, di, uo) is det.
+:- pred output_pragma_outputs(list(pragma_c_output), pragma_float_format,
+	io__state, io__state).
+:- mode output_pragma_outputs(in, in, di, uo) is det.
 
-output_pragma_outputs([]) --> [].
-output_pragma_outputs([O|Outputs]) --> 
-	{ O = pragma_c_output(Lval, Type, VarName) },
+output_pragma_outputs([], _) --> [].
+output_pragma_outputs([Output | Outputs], FloatFormat) --> 
+	{ Output = pragma_c_output(Lval, Type, VarName) },
 	io__write_string("\t"),
 	output_lval_as_word(Lval),
 	io__write_string(" = "),
@@ -1815,7 +1828,8 @@
 		io__write_string("(Word) "),
 		io__write_string(VarName)
 	;
-        	{ Type = term__functor(term__atom("float"), [], _) }
+        	{ Type = term__functor(term__atom("float"), [], _) },
+		{ FloatFormat = pragma_unboxed_float }
 	->
 		io__write_string("float_to_word("),
 		io__write_string(VarName),
@@ -1824,7 +1838,7 @@
 		io__write_string(VarName)
 	),
 	io__write_string(";\n"),
-	output_pragma_outputs(Outputs).
+	output_pragma_outputs(Outputs, FloatFormat).
 
 :- pred output_reset_trail_reason(reset_trail_reason, io__state, io__state).
 :- mode output_reset_trail_reason(in, di, uo) is det.
Index: middle_rec.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/middle_rec.m,v
retrieving revision 1.80
diff -u -b -r1.80 middle_rec.m
--- middle_rec.m	1999/11/15 00:42:37	1.80
+++ middle_rec.m	1999/12/27 23:45:14
@@ -424,7 +424,7 @@
 	middle_rec__find_used_registers_rval(Rval, Used0, Used).
 middle_rec__find_used_registers_instr(incr_sp(_, _), Used, Used).
 middle_rec__find_used_registers_instr(decr_sp(_), Used, Used).
-middle_rec__find_used_registers_instr(pragma_c(_, Components, _, _, _, _),
+middle_rec__find_used_registers_instr(pragma_c(_, Components, _, _, _, _, _),
 		Used0, Used) :-
 	middle_rec__find_used_registers_components(Components, Used0, Used).
 middle_rec__find_used_registers_instr(init_sync_term(Lval, _), Used0, Used) :-
Index: opt_debug.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_debug.m,v
retrieving revision 1.97
diff -u -b -r1.97 opt_debug.m
--- opt_debug.m	1999/11/15 00:42:40	1.97
+++ opt_debug.m	1999/12/28 00:10:48
@@ -956,7 +956,7 @@
 	opt_debug__dump_label(Label, LabelStr),
 	string__append_list(["join(", LvalStr, ", ", LabelStr, ")"], Str).
 % XXX  should probably give more info than this
-opt_debug__dump_instr(pragma_c(_, Comps, _, _, _, _), Str) :-
+opt_debug__dump_instr(pragma_c(_, Comps, _, _, _, _, _), Str) :-
 	opt_debug__dump_components(Comps, C_str),
 	string__append_list(["pragma_c(", C_str, ")"], Str).
 
Index: opt_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_util.m,v
retrieving revision 1.104
diff -u -b -r1.104 opt_util.m
--- opt_util.m	1999/11/15 00:42:41	1.104
+++ opt_util.m	1999/12/28 00:12:17
@@ -893,7 +893,7 @@
 		Uinstr0 = decr_sp(_),
 		Need = no
 	;
-		Uinstr0 = pragma_c(_, _, _, _, _, _),
+		Uinstr0 = pragma_c(_, _, _, _, _, _, _),
 		Need = no
 	;
 		Uinstr0 = init_sync_term(Lval, _),
@@ -1018,7 +1018,8 @@
 opt_util__can_instr_branch_away(fork(_, _, _), yes).
 opt_util__can_instr_branch_away(join_and_terminate(_), no).
 opt_util__can_instr_branch_away(join_and_continue(_, _), yes).
-opt_util__can_instr_branch_away(pragma_c(_, Comps, _, _, _, _), BranchAway) :-
+opt_util__can_instr_branch_away(pragma_c(_, Comps, _, _, _, _, _),
+		BranchAway) :-
 	opt_util__can_components_branch_away(Comps, BranchAway).
 
 :- pred opt_util__can_components_branch_away(list(pragma_c_component), bool).
@@ -1082,7 +1083,7 @@
 opt_util__can_instr_fall_through(fork(_, _, _), no).
 opt_util__can_instr_fall_through(join_and_terminate(_), no).
 opt_util__can_instr_fall_through(join_and_continue(_, _), no).
-opt_util__can_instr_fall_through(pragma_c(_, _, _, _, _, _), yes).
+opt_util__can_instr_fall_through(pragma_c(_, _, _, _, _, _, _), yes).
 
 	% Check whether an instruction sequence can possibly fall through
 	% to the next instruction without using its label.
@@ -1126,7 +1127,7 @@
 opt_util__can_use_livevals(fork(_, _, _), no).
 opt_util__can_use_livevals(join_and_terminate(_), no).
 opt_util__can_use_livevals(join_and_continue(_, _), no).
-opt_util__can_use_livevals(pragma_c(_, _, _, _, _, _), no).
+opt_util__can_use_livevals(pragma_c(_, _, _, _, _, _, _), no).
 
 % determine all the labels and code_addresses that are referenced by Instr
 
@@ -1187,7 +1188,7 @@
 opt_util__instr_labels_2(fork(Child, Parent, _), [Child, Parent], []).
 opt_util__instr_labels_2(join_and_terminate(_), [], []).
 opt_util__instr_labels_2(join_and_continue(_, Label), [Label], []).
-opt_util__instr_labels_2(pragma_c(_, _, _, MaybeFixLabel, MaybeSubLabel, _),
+opt_util__instr_labels_2(pragma_c(_, _, _, _, MaybeFixLabel, MaybeSubLabel, _),
 		Labels, []) :-
 	( MaybeFixLabel = yes(FixLabel) ->
 		( MaybeSubLabel = yes(SubLabel) ->
@@ -1244,7 +1245,7 @@
 opt_util__possible_targets(fork(Child, Parent, _), [Child, Parent]).
 opt_util__possible_targets(join_and_terminate(_), []).
 opt_util__possible_targets(join_and_continue(_, L), [L]).
-opt_util__possible_targets(pragma_c(_, _, _, MaybeFixLabel, MaybeSubLabel, _),
+opt_util__possible_targets(pragma_c(_,_,_,_, MaybeFixLabel, MaybeSubLabel, _),
 		Labels) :-
 	( MaybeFixLabel = yes(FixLabel) ->
 		( MaybeSubLabel = yes(SubLabel) ->
@@ -1291,7 +1292,7 @@
 opt_util__instr_rvals_and_lvals(fork(_, _, _), [], []).
 opt_util__instr_rvals_and_lvals(join_and_terminate(Lval), [], [Lval]).
 opt_util__instr_rvals_and_lvals(join_and_continue(Lval, _), [], [Lval]).
-opt_util__instr_rvals_and_lvals(pragma_c(_, Cs, _, _, _, _), Rvals, Lvals) :-
+opt_util__instr_rvals_and_lvals(pragma_c(_, Cs, _,_,_,_,_), Rvals, Lvals) :-
 	pragma_c_components_get_rvals_and_lvals(Cs, Rvals, Lvals).
 
 	% extract the rvals and lvals from the pragma_c_components
@@ -1436,7 +1437,7 @@
 	opt_util__count_temps_lval(Lval, R0, R, F0, F).
 opt_util__count_temps_instr(join_and_continue(Lval, _), R0, R, F0, F) :-
 	opt_util__count_temps_lval(Lval, R0, R, F0, F).
-opt_util__count_temps_instr(pragma_c(_, _, _, _, _, _), R, R, F, F).
+opt_util__count_temps_instr(pragma_c(_, _, _, _, _, _, _), R, R, F, F).
 
 :- pred opt_util__count_temps_lval(lval, int, int, int, int).
 :- mode opt_util__count_temps_lval(in, in, out, in, out) is det.
@@ -1543,7 +1544,7 @@
 		opt_util__touches_nondet_ctrl_lval(Lval, Touch)
 	; Uinstr = restore_hp(Rval) ->
 		opt_util__touches_nondet_ctrl_rval(Rval, Touch)
-	; Uinstr = pragma_c(_, Components, _, _, _, _) ->
+	; Uinstr = pragma_c(_, Components, _, _, _, _, _) ->
 		opt_util__touches_nondet_ctrl_components(Components, Touch)
 	;
 		Touch = yes
@@ -1879,8 +1880,9 @@
 		Replmap, _, join_and_continue(Lval, Label)) :-
 	opt_util__replace_labels_label(Label0, Replmap, Label),
 	opt_util__replace_labels_lval(Lval0, Replmap, Lval).
-opt_util__replace_labels_instr(pragma_c(A, Comps0, C, MaybeFix, MaybeSub0, F),
-		ReplMap, _, pragma_c(A, Comps, C, MaybeFix, MaybeSub, F)) :-
+opt_util__replace_labels_instr(
+		pragma_c(A, Comps0, C, D, MaybeFix, MaybeSub0, G), ReplMap, _,
+		pragma_c(A, Comps, C, D, MaybeFix, MaybeSub, G)) :-
 	(
 		MaybeFix = no
 	;
Index: pragma_c_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.33
diff -u -b -r1.33 pragma_c_gen.m
--- pragma_c_gen.m	1999/11/15 00:42:47	1.33
+++ pragma_c_gen.m	1999/12/27 23:17:37
@@ -335,6 +335,7 @@
 	%
 	{ may_call_mercury(Attributes, MayCallMercury) },
 	{ thread_safe(Attributes, ThreadSafe) },
+	{ pragma_float_format(Attributes, FloatFormat) },
 
 	%
 	% First we need to get a list of input and output arguments
@@ -485,7 +486,7 @@
 			CheckR1_Comp, RestoreRegsComp,
 			OutputComp, ProcLabelHashUndef] },
 	{ PragmaCCode = node([
-		pragma_c(Decls, Components, MayCallMercury, no,
+		pragma_c(Decls, Components, MayCallMercury, FloatFormat, no,
 			MaybeFailLabel, no)
 			- "Pragma C inclusion"
 	]) },
@@ -564,9 +565,10 @@
 	{ require(unify(CodeModel, model_non),
 		"inappropriate code model for nondet pragma C code") },
 	%
-	% Extract the may_call_mercury attribute
+	% Extract the relevant attributes
 	%
 	{ may_call_mercury(Attributes, MayCallMercury) },
+	{ pragma_float_format(Attributes, FloatFormat) },
 
 	%
 	% Generate #define MR_PROC_LABEL <procedure label> /* see note (5) */
@@ -752,7 +754,7 @@
 		],
 		CallBlockCode = node([
 			pragma_c(CallDecls, CallComponents,
-				MayCallMercury, no, no, yes)
+				MayCallMercury, FloatFormat, no, no, yes)
 				- "Call and shared pragma C inclusion"
 		]),
 
@@ -781,7 +783,7 @@
 		],
 		RetryBlockCode = node([
 			pragma_c(RetryDecls, RetryComponents,
-				MayCallMercury, no, no, yes)
+				MayCallMercury, FloatFormat, no, no, yes)
 				- "Retry and shared pragma C inclusion"
 		]),
 
@@ -838,7 +840,8 @@
 		],
 		CallBlockCode = node([
 			pragma_c(CallDecls, CallComponents,
-				MayCallMercury, yes(SharedLabel), no, yes)
+				MayCallMercury, FloatFormat,
+				yes(SharedLabel), no, yes)
 				- "Call pragma C inclusion"
 		]),
 
@@ -867,7 +870,8 @@
 		],
 		RetryBlockCode = node([
 			pragma_c(RetryDecls, RetryComponents,
-				MayCallMercury, yes(SharedLabel), no, yes)
+				MayCallMercury, FloatFormat,
+				yes(SharedLabel), no, yes)
 				- "Retry pragma C inclusion"
 		]),
 
@@ -895,7 +899,7 @@
 		],
 		SharedBlockCode = node([
 			pragma_c(SharedDecls, SharedComponents,
-				MayCallMercury, no, no, yes)
+				MayCallMercury, FloatFormat, no, no, yes)
 				- "Shared pragma C inclusion"
 		]),
 
Index: prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.50
diff -u -b -r1.50 prog_data.m
--- prog_data.m	1999/11/11 23:12:09	1.50
+++ prog_data.m	1999/12/26 00:12:08
@@ -499,6 +499,13 @@
 		pragma_c_code_attributes).
 :- mode set_thread_safe(in, in, out) is det.
 
+:- pred pragma_float_format(pragma_c_code_attributes, pragma_float_format).
+:- mode pragma_float_format(in, out) is det.
+
+:- pred set_pragma_float_format(pragma_c_code_attributes, pragma_float_format,
+		pragma_c_code_attributes).
+:- mode set_pragma_float_format(in, in, out) is det.
+
 	% For pragma c_code, there are two different calling conventions,
 	% one for C code that may recursively call Mercury code, and another
 	% more efficient one for the case when we know that the C code will
@@ -514,6 +521,21 @@
 	--->	not_thread_safe
 	;	thread_safe.
 
+	% By default, float arguments are passed to and from pragma C code
+	% in unboxed form, for programmer convenience. However, sometimes
+	% one wants control over boxing and unboxing operations for efficiency,
+	% e.g. we want to avoid reboxing a float that has just been unboxed
+	% by the pragma C code interface.
+	%
+	% This type says whether floats are passed boxed or unboxed. If
+	% boxed, the float arguments will of type word, and you must call
+	% word_to_float for inputs and float_to_word for outputs to perform
+	% the required conversions. On machines that always use unboxed floats,
+	% the conversion will be a no-op.
+:- type pragma_float_format
+	--->	pragma_boxed_float
+	;	pragma_unboxed_float.
+
 :- type pragma_var    
 	--->	pragma_var(prog_var, string, mode).
 	  	% variable, name, mode
@@ -886,23 +908,32 @@
 :- type pragma_c_code_attributes
 	--->	attributes(
 			may_call_mercury,
-			thread_safe
+			thread_safe,
+			pragma_float_format
 		).
 
-default_attributes(attributes(may_call_mercury, not_thread_safe)).
+default_attributes(attributes(may_call_mercury, not_thread_safe,
+	pragma_unboxed_float)).
 
 may_call_mercury(Attrs, MayCallMercury) :-
-	Attrs = attributes(MayCallMercury, _).
+	Attrs = attributes(MayCallMercury, _, _).
 
 thread_safe(Attrs, ThreadSafe) :-
-	Attrs = attributes(_, ThreadSafe).
+	Attrs = attributes(_, ThreadSafe, _).
+
+pragma_float_format(Attrs, PragmaFloatFormat) :-
+	Attrs = attributes(_, _, PragmaFloatFormat).
 
-set_may_call_mercury(Attrs0, MayCallMercury, Attrs) :-
-	Attrs0 = attributes(_, ThreadSafe),
-	Attrs  = attributes(MayCallMercury, ThreadSafe).
-
-set_thread_safe(Attrs0, ThreadSafe, Attrs) :-
-	Attrs0 = attributes(MayCallMercury, _),
-	Attrs  = attributes(MayCallMercury, ThreadSafe).
+set_may_call_mercury(Attrs0, A, Attrs) :-
+	Attrs0 = attributes(_, B, C),
+	Attrs  = attributes(A, B, C).
+
+set_thread_safe(Attrs0, B, Attrs) :-
+	Attrs0 = attributes(A, _, C),
+	Attrs  = attributes(A, B, C).
+
+set_pragma_float_format(Attrs0, C, Attrs) :-
+	Attrs0 = attributes(A, B, _),
+	Attrs  = attributes(A, B, C).
 
 %-----------------------------------------------------------------------------%
Index: prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.21
diff -u -b -r1.21 prog_io_pragma.m
--- prog_io_pragma.m	1999/07/13 08:53:24	1.21
+++ prog_io_pragma.m	1999/12/28 00:46:24
@@ -691,6 +691,7 @@
 :- type collected_pragma_c_code_attribute
 	--->	may_call_mercury(may_call_mercury)
 	;	thread_safe(thread_safe)
+	;	pragma_float_format(pragma_float_format)
 	.
 
 :- pred parse_pragma_c_code_attributes_term(term, pragma_c_code_attributes).
@@ -715,10 +716,22 @@
 			% XXX an error message would be nice
 			fail
 		;
-			set_thread_safe(Attributes1, thread_safe, Attributes)
+			set_thread_safe(Attributes1, thread_safe, Attributes2)
 		)
 	;
-		Attributes = Attributes1
+		Attributes2 = Attributes1
+	),
+	( list__member(pragma_float_format(pragma_boxed_float), AttrList) ->
+		( list__member(pragma_float_format(pragma_unboxed_float),
+				AttrList) ->
+			% XXX an error message would be nice
+			fail
+		;
+			set_pragma_float_format(Attributes2,
+				pragma_boxed_float, Attributes)
+		)
+	;
+		Attributes = Attributes2
 	).
 
 :- pred parse_pragma_c_code_attributes_term0(term,
@@ -751,6 +764,8 @@
 		Flag = may_call_mercury(MayCallMercury)
 	; parse_threadsafe(Term, ThreadSafe) ->
 		Flag = thread_safe(ThreadSafe)
+	; parse_pragma_float_format(Term, PragmaFloatFormat) ->
+		Flag = pragma_float_format(PragmaFloatFormat)
 	;
 		fail
 	).
@@ -774,6 +789,14 @@
 	thread_safe).
 parse_threadsafe(term__functor(term__atom("not_thread_safe"), [], _),
 	not_thread_safe).
+
+:- pred parse_pragma_float_format(term, pragma_float_format).
+:- mode parse_pragma_float_format(in, out) is semidet.
+
+parse_pragma_float_format(term__functor(term__atom("boxed_float"), [], _),
+	pragma_boxed_float).
+parse_pragma_float_format(term__functor(term__atom("unboxed_float"), [], _),
+	pragma_unboxed_float).
 
 % parse a pragma c_code declaration
 
Index: trace.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/trace.m,v
retrieving revision 1.29
diff -u -b -r1.29 trace.m
--- trace.m	1999/12/16 19:06:52	1.29
+++ trace.m	1999/12/28 00:13:31
@@ -423,7 +423,8 @@
 	),
 	TraceCode = node([
 		pragma_c([], [pragma_c_raw_code(TraceStmt)],
-			will_not_call_mercury, no, no, yes) - ""
+			will_not_call_mercury, pragma_boxed_float,
+			no, no, yes) - ""
 	])
 	}.
 
@@ -647,7 +648,8 @@
 				% by another label, and this way we can
 				% eliminate this other label.
 			pragma_c([], [pragma_c_raw_code(TraceStmt)],
-				may_call_mercury, yes(Label), no, yes)
+				may_call_mercury, pragma_boxed_float,
+				yes(Label), no, yes)
 				- ""
 		]),
 	Code = tree(ProduceCode, TraceCode)
Index: value_number.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/value_number.m,v
retrieving revision 1.100
diff -u -b -r1.100 value_number.m
--- value_number.m	1999/11/15 00:42:53	1.100
+++ value_number.m	1999/12/28 00:13:37
@@ -1101,7 +1101,7 @@
 value_number__boundary_instr(fork(_, _, _), yes).
 value_number__boundary_instr(join_and_terminate(_), yes).
 value_number__boundary_instr(join_and_continue(_, _), yes).
-value_number__boundary_instr(pragma_c(_, _, _, _, _, _), yes).
+value_number__boundary_instr(pragma_c(_, _, _, _, _, _, _), yes).
 
 %-----------------------------------------------------------------------------%
 
Index: vn_block.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_block.m,v
retrieving revision 1.61
diff -u -b -r1.61 vn_block.m
--- vn_block.m	1999/11/15 00:42:55	1.61
+++ vn_block.m	1999/12/28 00:13:51
@@ -360,7 +360,7 @@
 	vn_block__new_ctrl_node(vn_decr_sp(N), Livemap,
 		Params, VnTables0, VnTables,
 		Liveset0, Liveset, Tuple0, Tuple).
-vn_block__handle_instr(pragma_c(_, _, _, _, _, _),
+vn_block__handle_instr(pragma_c(_, _, _, _, _, _, _),
 		_Livemap, _Params, VnTables, VnTables, Liveset, Liveset,
 		SeenIncr, SeenIncr, Tuple, Tuple) :-
 	error("value numbering not supported for pragma_c").
@@ -918,7 +918,7 @@
 vn_block__is_ctrl_instr(fork(_, _, _), yes).
 vn_block__is_ctrl_instr(join_and_terminate(_), yes).
 vn_block__is_ctrl_instr(join_and_continue(_, _), yes).
-vn_block__is_ctrl_instr(pragma_c(_, _, _, _, _, _), no).
+vn_block__is_ctrl_instr(pragma_c(_, _, _, _, _, _, _), no).
 
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
Index: vn_cost.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_cost.m,v
retrieving revision 1.39
diff -u -b -r1.39 vn_cost.m
--- vn_cost.m	1999/11/15 00:42:55	1.39
+++ vn_cost.m	1999/12/28 00:13:57
@@ -178,7 +178,7 @@
 		Uinstr = decr_sp(_),
 		Cost = 0
 	;
-		Uinstr = pragma_c(_, _, _, _, _, _),
+		Uinstr = pragma_c(_, _, _, _, _, _, _),
 		error("pragma_c found in vn_block_cost")
 	;
 		Uinstr = init_sync_term(_, _),
Index: vn_filter.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_filter.m,v
retrieving revision 1.23
diff -u -b -r1.23 vn_filter.m
--- vn_filter.m	1999/11/15 00:42:56	1.23
+++ vn_filter.m	1999/12/28 00:14:16
@@ -153,7 +153,7 @@
 vn_filter__user_instr(discard_tickets_to(Rval), yes(Rval)).
 vn_filter__user_instr(incr_sp(_, _), no).
 vn_filter__user_instr(decr_sp(_), no).
-vn_filter__user_instr(pragma_c(_, _, _, _, _, _), _):-
+vn_filter__user_instr(pragma_c(_, _, _, _, _, _, _), _):-
 	error("inappropriate instruction in vn__filter").
 vn_filter__user_instr(init_sync_term(_, _), _):-
 	error("init_sync_term instruction in vn__filter").
@@ -221,7 +221,7 @@
 	error("non-user instruction in vn_filter__replace_in_user_instr").
 vn_filter__replace_in_user_instr(decr_sp(_), _, _, _) :-
 	error("non-user instruction in vn_filter__replace_in_user_instr").
-vn_filter__replace_in_user_instr(pragma_c(_, _, _, _, _, _), _, _, _):-
+vn_filter__replace_in_user_instr(pragma_c(_, _, _, _, _, _, _), _, _, _):-
 	error("inappropriate instruction in vn__filter").
 vn_filter__replace_in_user_instr(init_sync_term(_, _), _, _, _):-
 	error("init_sync_term instruction in vn__filter").
@@ -260,7 +260,7 @@
 vn_filter__defining_instr(discard_tickets_to(_), no).
 vn_filter__defining_instr(incr_sp(_, _), no).
 vn_filter__defining_instr(decr_sp(_), no).
-vn_filter__defining_instr(pragma_c(_, _, _, _, _, _), _):-
+vn_filter__defining_instr(pragma_c(_, _, _, _, _, _, _), _):-
 	error("inappropriate instruction in vn__filter").
 vn_filter__defining_instr(init_sync_term(_, _), _):-
 	error("init_sync_term instruction in vn__filter").
@@ -334,7 +334,7 @@
 	error("join_and_terminate instruction in vn_filter__replace_in_defining_instr").
 vn_filter__replace_in_defining_instr(join_and_continue(_, _), _, _, _):-
 	error("join_and_continue instruction in vn_filter__replace_in_defining_instr").
-vn_filter__replace_in_defining_instr(pragma_c(_, _, _, _, _, _), _, _, _):-
+vn_filter__replace_in_defining_instr(pragma_c(_, _, _, _, _, _, _), _, _, _) :-
 	error("inappropriate instruction in vn__filter").
 
 	% vn_filter__replace_in_lval(Lval0, Old, New, Lval):
Index: vn_verify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_verify.m,v
retrieving revision 1.23
diff -u -b -r1.23 vn_verify.m
--- vn_verify.m	1999/11/15 00:42:59	1.23
+++ vn_verify.m	1999/12/28 00:14:22
@@ -370,7 +370,7 @@
 		NoDeref = NoDeref0,
 		Tested = Tested0
 	;
-		Instr = pragma_c(_, _, _, _, _, _),
+		Instr = pragma_c(_, _, _, _, _, _, _),
 		error("found c_code in vn_verify__tags_instr")
 	).
 
cvs diff: Diffing notes
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to:       mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions:          mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------