[m-rev.] diff: dl.m versus --reserve-tag

[Fergus Henderson]

Estimated hours taken: 1

Fix a bug that broke tests/interactive_query in grade
asm_fast.gc.tr.rt.

browser/dl.m:
	Change the code for constructing closures so that it does not
	assume so much about how Mercury types get layed out in memory.
	Previously it was assuming that certain types with only one
	functor will have the same representation as closures, and in
	particular that they will have the same primary tag (zero),
	but that assumption is false with --reserve-tag.
	The fix was to write the code to allocate the closure
	structure in C rather than Mercury.

Workspace: /home/ceres/fjh/ws-ceres3/mercury
Index: browser/dl.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/dl.m,v
retrieving revision 1.17
diff -u -d -r1.17 dl.m
--- browser/dl.m	24 Feb 2002 11:53:21 -0000	1.17
+++ browser/dl.m	20 Mar 2002 15:38:25 -0000
@@ -130,31 +130,6 @@
 #endif
 }").
 
-	% closures for the LLDS backend
-:- type ll_closure
-	--->	ll_closure(
-			c_pointer,	% really MR_Closure_Layout
-			c_pointer,	% the address of the procedure to call
-			int		% the number of curried arguments;
-					% always zero, for closures created
-					% by dl.m
-		).
-
-	% closures for the --high-level-code (MLDS) backend
-:- type hl_closure
-	--->	hl_closure(
-			c_pointer,	% really MR_Closure_Layout
-			c_pointer,	% the wrapper function;
-					% this gets passed the closure
-					% as an argument
-			int,		% the number of curried arguments;
-					% always one, for closures created
-					% by dl.m
-			c_pointer	% the real function, which gets
-					% called by the wrapper function
-		).
-
-
 mercury_sym(Handle, MercuryProc0, Result) -->
 	{ check_proc_spec_matches_result_type(Result, _,
 		MercuryProc0, MercuryProc1) },
@@ -172,15 +147,15 @@
 		( high_level_code ->
 			NumCurriedInputArgs = 1,
 			ClosureLayout = make_closure_layout,
-			HL_Closure = hl_closure(ClosureLayout,
+			HL_Closure = make_closure(ClosureLayout,
 				dl__generic_closure_wrapper,
 				NumCurriedInputArgs, Address),
 			private_builtin__unsafe_type_cast(HL_Closure, Value)
 		;
 			NumCurriedInputArgs = 0,
 			ClosureLayout = make_closure_layout,
-			LL_Closure = ll_closure(ClosureLayout, Address,
-				NumCurriedInputArgs),
+			LL_Closure = make_closure(ClosureLayout, Address,
+				NumCurriedInputArgs, Address),
 			private_builtin__unsafe_type_cast(LL_Closure, Value)
 		),
 		Result = ok(Value)
@@ -236,6 +211,34 @@
 	closure_layout->MR_closure_dl_num_all_args = 0;
 
 	ClosureLayout = (MR_Word) closure_layout;
+}").
+
+:- func make_closure(c_pointer, c_pointer, int, c_pointer) = c_pointer.
+
+:- pragma foreign_proc("C", make_closure(ClosureLayout::in,
+	Address::in, NumArgs::in, FirstArg::in) = (Closure::out),
+	[will_not_call_mercury, promise_pure, thread_safe],
+"{
+	MR_Closure	*closure;
+	/*
+	** XXX All the allocations in this code should use malloc
+	** in deep profiling grades, perhaps?
+	*/
+	MR_incr_hp(MR_LVALUE_CAST(MR_Word, closure), 3 + NumArgs);
+	closure->MR_closure_layout = (MR_Closure_Layout *) ClosureLayout;
+	closure->MR_closure_code = (MR_Code *) Address;
+	closure->MR_closure_num_hidden_args = NumArgs;
+	switch (NumArgs) {
+	case 0:
+		break;
+	case 1:
+		closure->MR_closure_hidden_args(1) = FirstArg;
+		break;
+	default:
+		/* Not supported. */
+		MR_fatal_error(""dl.m: make_closure: NumArgs > 1"");
+	}
+	Closure = (MR_Word) closure;
 }").
 
 :- pragma c_header_code("

-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "I have always known that the pursuit
The University of Melbourne         |  of excellence is a lethal habit"
WWW: <http://www.cs.mu.oz.au/~fjh>  |     -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------