%-----------------------------------------------------------------------------% % Copyright (C) 1994-2000 The University of Melbourne. % This file may only be copied under the terms of the GNU Library General % Public License - see the file COPYING.LIB in the Mercury distribution. %-----------------------------------------------------------------------------% % File: std_util.m. % Main author: fjh. % Stability: medium to high. % This file is intended for all the useful standard utilities % that don't belong elsewhere, like in C. % Ralph Becket 24/04/99 % Function forms added. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- module std_util. :- interface. :- import_module list, set, bool. %-----------------------------------------------------------------------------% % The universal type `univ'. % An object of type `univ' can hold the type and value of an object of any % other type. :- type univ. % type_to_univ(Object, Univ): % true iff the type stored in `Univ' is the same as the type % of `Object', and the value stored in `Univ' is equal to the % value of `Object'. % % Operational, the forwards mode converts an object to type `univ', % while the reverse mode converts the value stored in `Univ' % to the type of `Object', but fails if the type stored in `Univ' % does not match the type of `Object'. % :- pred type_to_univ(T, univ). :- mode type_to_univ(di, uo) is det. :- mode type_to_univ(in, out) is det. :- mode type_to_univ(out, in) is semidet. % univ_to_type(Univ, Object) :- type_to_univ(Object, Univ). % :- pred univ_to_type(univ, T). :- mode univ_to_type(in, out) is semidet. :- mode univ_to_type(out, in) is det. :- mode univ_to_type(uo, di) is det. % The function univ/1 provides the same % functionality as type_to_univ/2. % univ(Object) = Univ :- type_to_univ(Object, Univ). % :- func univ(T) = univ. :- mode univ(in) = out is det. :- mode univ(di) = uo is det. :- mode univ(out) = in is semidet. % det_univ_to_type(Univ, Object): % the same as the forwards mode of univ_to_type, but % abort if univ_to_type fails. % :- pred det_univ_to_type(univ, T). :- mode det_univ_to_type(in, out) is det. % univ_type(Univ): % returns the type_info for the type stored in `Univ'. % :- func univ_type(univ) = type_info. % univ_value(Univ): % returns the value of the object stored in Univ. :- some [T] func univ_value(univ) = T. %-----------------------------------------------------------------------------% % The "maybe" type. :- type maybe(T) ---> no ; yes(T). :- type maybe_error ---> ok ; error(string). :- type maybe_error(T) ---> ok(T) ; error(string). %-----------------------------------------------------------------------------% % The "unit" type - stores no information at all. :- type unit ---> unit. %-----------------------------------------------------------------------------% % The "pair" type. Useful for many purposes. :- type pair(T1, T2) ---> (T1 - T2). :- type pair(T) == pair(T,T). % Return the first element of the pair. :- pred fst(pair(X,Y)::in, X::out) is det. :- func fst(pair(X,Y)) = X. % Return the second element of the pair. :- pred snd(pair(X,Y)::in, Y::out) is det. :- func snd(pair(X,Y)) = Y. %-----------------------------------------------------------------------------% % solutions/2 collects all the solutions to a predicate and % returns them as a list in sorted order, with duplicates removed. % solutions_set/2 returns them as a set. % unsorted_solutions/2 returns them as an unsorted list with possible % duplicates; since there are an infinite number of such lists, % this must be called from a context in which only a single solution % is required. :- pred solutions(pred(T), list(T)). :- mode solutions(pred(out) is multi, out) is det. :- mode solutions(pred(out) is nondet, out) is det. :- pred solutions_set(pred(T), set(T)). :- mode solutions_set(pred(out) is multi, out) is det. :- mode solutions_set(pred(out) is nondet, out) is det. :- pred unsorted_solutions(pred(T), list(T)). :- mode unsorted_solutions(pred(out) is multi, out) is cc_multi. :- mode unsorted_solutions(pred(out) is nondet, out) is cc_multi. %-----------------------------------------------------------------------------% % aggregate/4 generates all the solutions to a predicate, % sorts them and removes duplicates, then applies an accumulator % predicate to each solution in turn: % % aggregate(Generator, Accumulator, Acc0, Acc) <=> % solutions(Generator, Solutions), % list__foldl(Accumulator, Solutions, Acc0, Acc). % :- pred aggregate(pred(T), pred(T, U, U), U, U). :- mode aggregate(pred(out) is multi, pred(in, in, out) is det, in, out) is det. :- mode aggregate(pred(out) is multi, pred(in, di, uo) is det, di, uo) is det. :- mode aggregate(pred(out) is nondet, pred(in, di, uo) is det, di, uo) is det. :- mode aggregate(pred(out) is nondet, pred(in, in, out) is det, in, out) is det. % unsorted_aggregate/4 generates all the solutions to a predicate % and applies an accumulator predicate to each solution in turn. % Declaratively, the specification is as follows: % % unsorted_aggregate(Generator, Accumulator, Acc0, Acc) <=> % unsorted_solutions(Generator, Solutions), % list__foldl(Accumulator, Solutions, Acc0, Acc). % % Operationally, however, unsorted_aggregate/4 will call the % Accumulator for each solution as it is obtained, rather than % first building a list of all the solutions. :- pred unsorted_aggregate(pred(T), pred(T, U, U), U, U). :- mode unsorted_aggregate(pred(out) is multi, pred(in, in, out) is det, in, out) is cc_multi. :- mode unsorted_aggregate(pred(out) is multi, pred(in, di, uo) is det, di, uo) is cc_multi. :- mode unsorted_aggregate(pred(muo) is multi, pred(mdi, di, uo) is det, di, uo) is cc_multi. :- mode unsorted_aggregate(pred(out) is nondet, pred(in, di, uo) is det, di, uo) is cc_multi. :- mode unsorted_aggregate(pred(out) is nondet, pred(in, in, out) is det, in, out) is cc_multi. :- mode unsorted_aggregate(pred(muo) is nondet, pred(mdi, di, uo) is det, di, uo) is cc_multi. % This is a generalization of unsorted_aggregate which allows the % iteration to stop before all solutions have been found. % Declaratively, the specification is as follows: % % do_while(Generator, Filter) --> % { unsorted_solutions(Generator, Solutions) }, % do_while_2(Solutions, Filter). % % do_while_2([], _) --> []. % do_while_2([X|Xs], Filter) --> % Filter(X, More), % (if { More = yes } then % do_while_2(Xs, Filter) % else % { true } % ). % % Operationally, however, do_while/4 will call the Filter % predicate for each solution as it is obtained, rather than % first building a list of all the solutions. % :- pred do_while(pred(T), pred(T, bool, T2, T2), T2, T2). :- mode do_while(pred(out) is multi, pred(in, out, in, out) is det, in, out) is cc_multi. :- mode do_while(pred(out) is nondet, pred(in, out, in, out) is det, in, out) is cc_multi. :- mode do_while(pred(out) is multi, pred(in, out, di, uo) is det, di, uo) is cc_multi. :- mode do_while(pred(out) is nondet, pred(in, out, di, uo) is det, di, uo) is cc_multi. %-----------------------------------------------------------------------------% % maybe_pred(Pred, X, Y) takes a closure Pred which transforms an % input semideterministically. If calling the closure with the input % X succeeds, Y is bound to `yes(Z)' where Z is the output of the % call, or to `no' if the call fails. % :- pred maybe_pred(pred(T1, T2), T1, maybe(T2)). :- mode maybe_pred(pred(in, out) is semidet, in, out) is det. %-----------------------------------------------------------------------------% % `semidet_succeed' is exactly the same as `true', except that % the compiler thinks that it is semi-deterministic. You can % use calls to `semidet_succeed' to suppress warnings about % determinism declarations which could be stricter. % Similarly, `semidet_fail' is like `fail' except that its % determinism is semidet rather than failure, and % `cc_multi_equal(X,Y)' is the same as `X=Y' except that it % is cc_multi rather than det. :- pred semidet_succeed is semidet. :- pred semidet_fail is semidet. :- pred cc_multi_equal(T, T). :- mode cc_multi_equal(di, uo) is cc_multi. :- mode cc_multi_equal(in, out) is cc_multi. %-----------------------------------------------------------------------------% % The `type_info' and `type_ctor_info' types: these % provide access to type information. % A type_info represents a type, e.g. `list(int)'. % A type_ctor_info represents a type constructor, e.g. `list/1'. :- type type_info. :- type type_ctor_info. % (Note: it is not possible for the type of a variable to be an % unbound type variable; if there are no constraints on a type % variable, then the typechecker will use the type `void'. % `void' is a special (builtin) type that has no constructors. % There is no way of creating an object of type `void'. % `void' is not considered to be a discriminated union, so % get_functor/5 and construct/3 will fail if used upon a value % of this type.) % The function type_of/1 returns a representation of the type % of its argument. % :- func type_of(T) = type_info. :- mode type_of(unused) = out is det. % The predicate has_type/2 is basically an existentially typed % inverse to the function type_of/1. It constrains the type % of the first argument to be the type represented by the % second argument. :- some [T] pred has_type(T::unused, type_info::in) is det. % type_name(Type) returns the name of the specified type % (e.g. type_name(type_of([2,3])) = "list:list(int)"). % Any equivalence types will be fully expanded. % Builtin types (those defined in builtin.m) will % not have a module qualifier. % :- func type_name(type_info) = string. % type_ctor_and_args(Type, TypeCtor, TypeArgs): % True iff `TypeCtor' is a representation of the top-level % type constructor for `Type', and `TypeArgs' is a list % of the corresponding type arguments to `TypeCtor', % and `TypeCtor' is not an equivalence type. % % For example, type_ctor_and_args(type_of([2,3]), TypeCtor, % TypeArgs) will bind `TypeCtor' to a representation of the % type constructor list/1, and will bind `TypeArgs' to the list % `[Int]', where `Int' is a representation of the type `int'. % % Note that the requirement that `TypeCtor' not be an % equivalence type is fulfilled by fully expanding any % equivalence types. For example, if you have a declaration % `:- type foo == bar.', then type_ctor_and_args/3 will always % return a representation of type constructor `bar/0', not `foo/0'. % (If you don't want them expanded, you can use the reverse mode % of make_type/2 instead.) % :- pred type_ctor_and_args(type_info, type_ctor_info, list(type_info)). :- mode type_ctor_and_args(in, out, out) is det. % type_ctor(Type) = TypeCtor :- % type_ctor_and_args(Type, TypeCtor, _). % :- func type_ctor(type_info) = type_ctor_info. % type_args(Type) = TypeArgs :- % type_ctor_and_args(Type, _, TypeArgs). % :- func type_args(type_info) = list(type_info). % type_ctor_name(TypeCtor) returns the name of specified % type constructor. % (e.g. type_ctor_name(type_ctor(type_of([2,3]))) = "list"). % :- func type_ctor_name(type_ctor_info) = string. % type_ctor_module_name(TypeCtor) returns the module name of specified % type constructor. % (e.g. type_ctor_module_name(type_ctor(type_of(2))) = "builtin"). % :- func type_ctor_module_name(type_ctor_info) = string. % type_ctor_arity(TypeCtor) returns the arity of specified % type constructor. % (e.g. type_ctor_arity(type_ctor(type_of([2,3]))) = 1). % :- func type_ctor_arity(type_ctor_info) = int. % type_ctor_name_and_arity(TypeCtor, ModuleName, TypeName, Arity) :- % Name = type_ctor_name(TypeCtor), % ModuleName = type_ctor_module_name(TypeCtor), % Arity = type_ctor_arity(TypeCtor). % :- pred type_ctor_name_and_arity(type_ctor_info, string, string, int). :- mode type_ctor_name_and_arity(in, out, out, out) is det. % make_type(TypeCtor, TypeArgs) = Type: % True iff `Type' is a type constructed by applying % the type constructor `TypeCtor' to the type arguments % `TypeArgs'. % % Operationally, the forwards mode returns the type formed by % applying the specified type constructor to the specified % argument types, or fails if the length of TypeArgs is not the % same as the arity of TypeCtor. The reverse mode returns a % type constructor and its argument types, given a type_info; % the type constructor returned may be an equivalence type % (and hence this reverse mode of make_type/2 may be more useful % for some purposes than the type_ctor/1 function). % :- func make_type(type_ctor_info, list(type_info)) = type_info. :- mode make_type(in, in) = out is semidet. :- mode make_type(out, out) = in is cc_multi. % det_make_type(TypeCtor, TypeArgs): % % Returns the type formed by applying the specified type % constructor to the specified argument types. Aborts if the % length of `TypeArgs' is not the same as the arity of `TypeCtor'. % :- func det_make_type(type_ctor_info, list(type_info)) = type_info. :- mode det_make_type(in, in) = out is det. %-----------------------------------------------------------------------------% % num_functors(TypeInfo) % % Returns the number of different functors for the top-level % type constructor of the type specified by TypeInfo, or -1 % if the type is not a discriminated union type. % :- func num_functors(type_info) = int. % get_functor(Type, N, Functor, Arity, ArgTypes) % % Binds Functor and Arity to the name and arity of the Nth % functor for the specified type (starting at zero), and binds % ArgTypes to the type_infos for the types of the arguments of % that functor. Fails if the type is not a discriminated union % type, or if N is out of range. % :- pred get_functor(type_info::in, int::in, string::out, int::out, list(type_info)::out) is semidet. % construct(TypeInfo, N, Args) = Term % % Returns a term of the type specified by TypeInfo whose functor % is the Nth functor of TypeInfo (starting at zero), and whose % arguments are given by Args. Fails if the type is not a % discriminated union type, or if N is out of range, or if the % number of arguments doesn't match the arity of the Nth functor % of the type, or if the types of the arguments doesn't match % the expected argument types for that functor. % :- func construct(type_info, int, list(univ)) = univ. :- mode construct(in, in, in) = out is semidet. %-----------------------------------------------------------------------------% % functor, argument and deconstruct take any type (including univ), % and return representation information for that type. % % The string representation of the functor that `functor' and % `deconstruct' return is: % - for user defined types, the functor that is given % in the type definition. For lists, this % means the functors ./2 and []/0 are used, even if % the list uses the [....] shorthand. % - for integers, the string is a base 10 number, % positive integers have no sign. % - for floats, the string is a floating point, % base 10 number, positive floating point numbers have % no sign. % - for strings, the string, inside double quotation marks % - for characters, the character inside single % quotation marks % - for predicates and functions, the string % <> % functor(Data, Functor, Arity) % % Given a data item (Data), binds Functor to a string % representation of the functor and Arity to the arity of this % data item. (Aborts if the type of Data is a type with a % non-canonical representation, i.e. one for which there is a % user-defined equality predicate.) % :- pred functor(T::in, string::out, int::out) is det. % arg(Data, ArgumentIndex) = Argument % argument(Data, ArgumentIndex) = ArgumentUniv % % Given a data item (Data) and an argument index % (ArgumentIndex), starting at 0 for the first argument, binds % Argument to that argument of the functor of the data item. If % the argument index is out of range -- that is, greater than or % equal to the arity of the functor or lower than 0 -- then % the call fails. For argument/1 the argument returned has the % type univ, which can store any type. For arg/1, if the % argument has the wrong type, then the call fails. % (Both abort if the type of Data is a type with a non-canonical % representation, i.e. one for which there is a user-defined % equality predicate.) % :- func arg(T::in, int::in) = (ArgT::out) is semidet. :- func argument(T::in, int::in) = (univ::out) is semidet. % det_arg(Data, ArgumentIndex) = Argument % det_argument(Data, ArgumentIndex) = ArgumentUniv % % Same as arg/2 and argument/2 respectively, except that % for cases where arg/2 or argument/2 would fail, % det_arg/2 or det_argument/2 will abort. % :- func det_arg(T::in, int::in) = (ArgT::out) is det. :- func det_argument(T::in, int::in) = (univ::out) is det. % deconstruct(Data, Functor, Arity, Arguments) % % Given a data item (Data), binds Functor to a string % representation of the functor, Arity to the arity of this data % item, and Arguments to a list of arguments of the functor. % The arguments in the list are each of type univ. % (Aborts if the type of Data is a type with a non-canonical % representation, i.e. one for which there is a user-defined % equality predicate.) % :- pred deconstruct(T::in, string::out, int::out, list(univ)::out) is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module require, set, int, string, bool. %-----------------------------------------------------------------------------% /**** Is this really useful? % for use in lambda expressions where the type of functor '-' is ambiguous :- pred pair(X, Y, pair(X, Y)). :- mode pair(in, in, out) is det. :- mode pair(out, out, in) is det. pair(X, Y, X-Y). ****/ fst(X-_Y) = X. fst(P,X) :- X = fst(P). snd(_X-Y) = Y. snd(P,X) :- X = snd(P). maybe_pred(Pred, X, Y) :- ( call(Pred, X, Z) -> Y = yes(Z) ; Y = no ). %-----------------------------------------------------------------------------% /* ** This section defines builtin_aggregate/4 which takes a closure of type ** pred(T) in which the remaining argument is output, and backtracks over ** solutions for this, using the second argument to aggregate them however the ** user wishes. This is basically a generalization of solutions/2. */ :- pred builtin_aggregate(pred(T), pred(T, U, U), U, U). :- mode builtin_aggregate(pred(out) is multi, pred(in, in, out) is det, in, out) is det. /* really cc_multi */ :- mode builtin_aggregate(pred(out) is multi, pred(in, di, uo) is det, di, uo) is det. /* really cc_multi */ :- mode builtin_aggregate(pred(muo) is multi, pred(mdi, di, uo) is det, di, uo) is det. /* really cc_multi */ :- mode builtin_aggregate(pred(out) is nondet, pred(in, di, uo) is det, di, uo) is det. /* really cc_multi */ :- mode builtin_aggregate(pred(out) is nondet, pred(in, in, out) is det, in, out) is det. /* really cc_multi */ :- mode builtin_aggregate(pred(muo) is nondet, pred(mdi, di, uo) is det, di, uo) is det. /* really cc_multi */ /* ** In order to implement any sort of code that requires terms to survive ** backtracking, we need to (deeply) copy them out of the heap and into some ** other area before backtracking. The obvious thing to do then is just call ** the generator predicate, let it run to completion, and copy its result into ** another memory area (call it the solutions heap) before forcing ** backtracking. When we get the next solution, we do the same, this time ** passing the previous collection (which is still on the solutions heap) to ** the collector predicate. If the result of this operation contains the old ** collection as a part, then the deep copy operation is smart enough ** not to copy again. So this could be pretty efficient. ** ** But what if the collector predicate does something that copies the previous ** collection? Then on each solution, we'll copy the previous collection to ** the heap, and then deep copy it back to the solution heap. This means ** copying solutions order N**2 times, where N is the number of solutions. So ** this isn't as efficient as we hoped. ** ** So we use a slightly different approach. When we find a solution, we deep ** copy it to the solution heap. Then, before calling the collector code, we ** sneakily swap the runtime system's notion of which is the heap and which is ** the solutions heap. This ensures that any terms are constructed on the ** solutions heap. When this is complete, we swap them back, and force the ** engine to backtrack to get the next solution. And so on. After we've ** gotten the last solution, we do another deep copy to move the solution back ** to the 'real' heap, and reset the solutions heap pointer (which of course ** reclaims all the garbage of the collection process). ** ** Note that this will work with recursive calls to builtin_aggregate as ** well. If the recursive invocation occurs in the generator pred, there can ** be no problem because by the time the generator succeeds, the inner ** do_ call will have completed, copied its result from the solutions heap, ** and reset the solutions heap pointer. If the recursive invocation happens ** in the collector pred, then it will happen when the heap and solutions heap ** are 'swapped.' This will work out fine, because the real heap isn't needed ** while the collector pred is executing, and by the time the nested do_ is ** completed, the 'real' heap pointer will have been reset. ** ** If the collector predicate throws an exception while they are swapped, ** then the code for builtin_throw/1 will unswap the heaps. ** So we don't need to create our own exception handlers to here to ** cover that case. ** ** If we're using conservative GC, then all of the heap-swapping ** and copying operations are no-ops, so we get a "zero-copy" solution. */ % Note that the code for builtin_aggregate is very similar to the code % for do_while (below). :- pragma promise_pure(builtin_aggregate/4). builtin_aggregate(GeneratorPred, CollectorPred, Accumulator0, Accumulator) :- % Save some of the Mercury virtual machine registers impure get_registers(HeapPtr, SolutionsHeapPtr, TrailPtr), % Initialize the accumulator % /* Mutvar := Accumulator0 */ impure new_mutvar(Accumulator0, Mutvar), ( % Get a solution GeneratorPred(Answer0), % Check that the generator didn't leave any % delayed goals outstanding impure check_for_floundering(TrailPtr), % Update the accumulator % /* MutVar := CollectorPred(MutVar) */ impure swap_heap_and_solutions_heap, impure partial_deep_copy(HeapPtr, Answer0, Answer), impure get_mutvar(Mutvar, Acc0), CollectorPred(Answer, Acc0, Acc1), impure set_mutvar(Mutvar, Acc1), impure swap_heap_and_solutions_heap, % Force backtracking, so that we get the next solution. % This will automatically reset the heap and trail. fail ; % There are no more solutions. % So now we just need to copy the final value % of the accumulator from the solutions heap % back onto the ordinary heap, and then we can % reset the solutions heap pointer. % /* Accumulator := MutVar */ impure get_mutvar(Mutvar, Accumulator1), impure partial_deep_copy(SolutionsHeapPtr, Accumulator1, Accumulator), impure reset_solutions_heap(SolutionsHeapPtr) ). % The code for do_while/4 is essentially the same as the code for % builtin_aggregate (above). See the detailed comments above. % % XXX It would be nice to avoid the code duplication here, % but it is a bit tricky -- we can't just use a lambda expression, % because we'd need to specify the mode, but we want it to work % for multiple modes. An alternative would be to use a typeclass, % but typeclasses still don't work in `jump' or `fast' grades. :- pragma promise_pure(do_while/4). do_while(GeneratorPred, CollectorPred, Accumulator0, Accumulator) :- impure get_registers(HeapPtr, SolutionsHeapPtr, TrailPtr), impure new_mutvar(Accumulator0, Mutvar), ( GeneratorPred(Answer0), impure check_for_floundering(TrailPtr), impure swap_heap_and_solutions_heap, impure partial_deep_copy(HeapPtr, Answer0, Answer), impure get_mutvar(Mutvar, Acc0), CollectorPred(Answer, More, Acc0, Acc1), impure set_mutvar(Mutvar, Acc1), impure swap_heap_and_solutions_heap, % if More = yes, then backtrack for the next solution. % if More = no, then we're done. More = no ; true ), impure get_mutvar(Mutvar, Accumulator1), impure partial_deep_copy(SolutionsHeapPtr, Accumulator1, Accumulator), impure reset_solutions_heap(SolutionsHeapPtr). :- type heap_ptr ---> heap_ptr(c_pointer). :- type trail_ptr ---> trail_ptr(c_pointer). % % Save the state of the Mercury heap and trail registers, % for later use in partial_deep_copy/3 and reset_solutions_heap/1. % :- impure pred get_registers(heap_ptr::out, heap_ptr::out, trail_ptr::out) is det. :- pragma c_code(get_registers(HeapPtr::out, SolutionsHeapPtr::out, TrailPtr::out), will_not_call_mercury, " /* save heap states */ #ifndef CONSERVATIVE_GC HeapPtr = MR_hp; SolutionsHeapPtr = MR_sol_hp; #else HeapPtr = SolutionsHeapPtr = 0; #endif /* save trail state */ #ifdef MR_USE_TRAIL MR_store_ticket(TrailPtr); #else TrailPtr = 0; #endif "). :- impure pred check_for_floundering(trail_ptr::in) is det. :- pragma c_code(check_for_floundering(TrailPtr::in), [will_not_call_mercury], " #ifdef MR_USE_TRAIL /* check for outstanding delayed goals (``floundering'') */ MR_reset_ticket(TrailPtr, MR_solve); #endif "). % % Swap the heap with the solutions heap % :- impure pred swap_heap_and_solutions_heap is det. :- pragma c_code(swap_heap_and_solutions_heap, will_not_call_mercury, " #ifndef CONSERVATIVE_GC { MemoryZone *temp_zone; Word *temp_hp; temp_zone = MR_ENGINE(heap_zone); MR_ENGINE(heap_zone) = MR_ENGINE(solutions_heap_zone); MR_ENGINE(solutions_heap_zone) = temp_zone; temp_hp = MR_hp; MR_hp = MR_sol_hp; MR_sol_hp = temp_hp; } #endif "). % % partial_deep_copy(SolutionsHeapPtr, OldVal, NewVal): % Make a copy of all of the parts of OldVar that occur between % SolutionsHeapPtr and the top of the current solutions heap. % :- impure pred partial_deep_copy(heap_ptr, T, T) is det. :- mode partial_deep_copy(in, di, uo) is det. :- mode partial_deep_copy(in, mdi, muo) is det. :- mode partial_deep_copy(in, in, out) is det. :- pragma c_header_code(" #include ""mercury_deep_copy.h"" #ifdef CONSERVATIVE_GC /* for conservative GC, shallow copies suffice */ #define MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, \\ OldVar, NewVal, TypeInfo_for_T) \\ do { \\ NewVal = OldVal; \\ } while (0) #else /* ** Note that we need to save/restore the MR_hp register, if it ** is transient, before/after calling deep_copy(). */ #define MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, \\ OldVar, NewVal, TypeInfo_for_T) \\ do { \\ save_transient_hp(); \\ NewVal = deep_copy(&OldVal, TypeInfo_for_T, \\ SolutionsHeapPtr, \\ MR_ENGINE(solutions_heap_zone)->top); \\ restore_transient_hp(); \\ } while (0) #endif "). :- pragma c_code(partial_deep_copy(SolutionsHeapPtr::in, OldVal::in, NewVal::out), will_not_call_mercury, " MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, OldVal, NewVal, TypeInfo_for_T); "). :- pragma c_code(partial_deep_copy(SolutionsHeapPtr::in, OldVal::mdi, NewVal::muo), will_not_call_mercury, " MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, OldVal, NewVal, TypeInfo_for_T); "). :- pragma c_code(partial_deep_copy(SolutionsHeapPtr::in, OldVal::di, NewVal::uo), will_not_call_mercury, " MR_PARTIAL_DEEP_COPY(SolutionsHeapPtr, OldVal, NewVal, TypeInfo_for_T); "). % % reset_solutions_heap(SolutionsHeapPtr): % Reset the solutions heap pointer to the specified value, % thus deallocating everything allocated on the solutions % heap since that value was obtained via get_registers/3. % :- impure pred reset_solutions_heap(heap_ptr::in) is det. :- pragma c_code(reset_solutions_heap(SolutionsHeapPtr::in), will_not_call_mercury, " #ifndef CONSERVATIVE_GC MR_sol_hp = SolutionsHeapPtr; #endif "). %-----------------------------------------------------------------------------% %%% :- module mutvar. %%% :- interface. % A non-backtrackably destructively modifiable reference type :- type mutvar(T). % Create a new mutvar given a term for it to reference. :- impure pred new_mutvar(T, mutvar(T)). :- mode new_mutvar(in, out) is det. :- mode new_mutvar(di, uo) is det. % Get the value currently referred to by a reference. :- impure pred get_mutvar(mutvar(T), T) is det. :- mode get_mutvar(in, uo) is det. % XXX this is a work-around /* XXX `ui' modes don't work yet :- mode get_mutvar(in, uo) is det. :- mode get_mutvar(ui, uo) is det. % unsafe, but we use it safely */ % destructively modify a reference to refer to a new object. :- impure pred set_mutvar(mutvar(T), T) is det. :- mode set_mutvar(in, in) is det. /* XXX `ui' modes don't work yet :- pred set_mutvar(ui, di) is det. */ %%% :- implementation. % This type is implemented in C. :- type mutvar(T) ---> mutvar(c_pointer). :- pragma inline(new_mutvar/2). :- pragma c_code(new_mutvar(X::in, Ref::out), will_not_call_mercury, " incr_hp_msg(Ref, 1, MR_PROC_LABEL, ""std_util:mutvar/1""); *(Word *) Ref = X; "). :- pragma c_code(new_mutvar(X::di, Ref::uo), will_not_call_mercury, " incr_hp_msg(Ref, 1, MR_PROC_LABEL, ""std_util:mutvar/1""); *(Word *) Ref = X; "). :- pragma inline(get_mutvar/2). :- pragma c_code(get_mutvar(Ref::in, X::uo), will_not_call_mercury, " X = *(Word *) Ref; "). :- pragma inline(set_mutvar/2). :- pragma c_code(set_mutvar(Ref::in, X::in), will_not_call_mercury, " *(Word *) Ref = X; "). %%% end_module mutvar. %-----------------------------------------------------------------------------% solutions(Pred, List) :- builtin_solutions(Pred, UnsortedList), list__sort_and_remove_dups(UnsortedList, List). solutions_set(Pred, Set) :- builtin_solutions(Pred, List), set__list_to_set(List, Set). unsorted_solutions(Pred, List) :- builtin_solutions(Pred, UnsortedList), cc_multi_equal(UnsortedList, List). :- pred builtin_solutions(pred(T), list(T)). :- mode builtin_solutions(pred(out) is multi, out) is det. /* really cc_multi */ :- mode builtin_solutions(pred(out) is nondet, out) is det. /* really cc_multi */ builtin_solutions(Generator, UnsortedList) :- builtin_aggregate(Generator, cons, [], UnsortedList). :- pred cons(T::in, list(T)::in, list(T)::out) is det. cons(H, T, [H|T]). %-----------------------------------------------------------------------------% aggregate(Generator, Accumulator, Acc0, Acc) :- solutions(Generator, Solutions), list__foldl(Accumulator, Solutions, Acc0, Acc). unsorted_aggregate(Generator, Accumulator, Acc0, Acc) :- builtin_aggregate(Generator, Accumulator, Acc0, Acc1), cc_multi_equal(Acc1, Acc). %-----------------------------------------------------------------------------% % semidet_succeed and semidet_fail, implemented using the C interface % to make sure that the compiler doesn't issue any determinism warnings % for them. :- pragma c_code(semidet_succeed, [will_not_call_mercury, thread_safe], "SUCCESS_INDICATOR = TRUE;"). :- pragma c_code(semidet_fail, [will_not_call_mercury, thread_safe], "SUCCESS_INDICATOR = FALSE;"). :- pragma c_code(cc_multi_equal(X::in, Y::out), [will_not_call_mercury, thread_safe], "Y = X;"). :- pragma c_code(cc_multi_equal(X::di, Y::uo), [will_not_call_mercury, thread_safe], "Y = X;"). %-----------------------------------------------------------------------------% % The type `std_util:type_info/0' happens to use much the same % representation as `private_builtin:type_info/1'. univ_to_type(Univ, X) :- type_to_univ(X, Univ). univ(X) = Univ :- type_to_univ(X, Univ). det_univ_to_type(Univ, X) :- ( type_to_univ(X0, Univ) -> X = X0 ; UnivTypeName = type_name(univ_type(Univ)), ObjectTypeName = type_name(type_of(X)), string__append_list(["det_univ_to_type: conversion failed\\n", "\tUniv Type: ", UnivTypeName, "\\n\tObject Type: ", ObjectTypeName], ErrorString), error(ErrorString) ). :- pragma c_code(univ_value(Univ::in) = (Value::out), will_not_call_mercury, " TypeInfo_for_T = MR_field(MR_mktag(0), Univ, UNIV_OFFSET_FOR_TYPEINFO); Value = MR_field(MR_mktag(0), Univ, UNIV_OFFSET_FOR_DATA); "). :- pragma c_header_code(" /* ** `univ' is represented as a two word structure. ** One word contains the address of a type_info for the type. ** The other word contains the data. ** The offsets UNIV_OFFSET_FOR_TYPEINFO and UNIV_OFFSET_FOR_DATA ** are defined in runtime/type_info.h. */ #include ""mercury_type_info.h"" "). % :- pred type_to_univ(T, univ). % :- mode type_to_univ(di, uo) is det. % :- mode type_to_univ(in, out) is det. % :- mode type_to_univ(out, in) is semidet. % Forward mode - convert from type to univ. % Allocate heap space, set the first field to contain the address % of the type_info for this type, and then store the input argument % in the second field. :- pragma c_code(type_to_univ(Type::di, Univ::uo), will_not_call_mercury, " incr_hp_msg(Univ, 2, MR_PROC_LABEL, ""std_util:univ/0""); MR_field(MR_mktag(0), Univ, UNIV_OFFSET_FOR_TYPEINFO) = (Word) TypeInfo_for_T; MR_field(MR_mktag(0), Univ, UNIV_OFFSET_FOR_DATA) = (Word) Type; "). :- pragma c_code(type_to_univ(Type::in, Univ::out), will_not_call_mercury, " incr_hp_msg(Univ, 2, MR_PROC_LABEL, ""std_util:univ/0""); MR_field(MR_mktag(0), Univ, UNIV_OFFSET_FOR_TYPEINFO) = (Word) TypeInfo_for_T; MR_field(MR_mktag(0), Univ, UNIV_OFFSET_FOR_DATA) = (Word) Type; "). % Backward mode - convert from univ to type. % We check that type_infos compare equal. % The variable `TypeInfo_for_T' used in the C code % is the compiler-introduced type-info variable. :- pragma c_code(type_to_univ(Type::out, Univ::in), will_not_call_mercury, "{ Word univ_type_info; int comp; univ_type_info = MR_field(MR_mktag(0), Univ, UNIV_OFFSET_FOR_TYPEINFO); save_transient_registers(); comp = MR_compare_type_info(univ_type_info, TypeInfo_for_T); restore_transient_registers(); if (comp == MR_COMPARE_EQUAL) { Type = MR_field(MR_mktag(0), Univ, UNIV_OFFSET_FOR_DATA); SUCCESS_INDICATOR = TRUE; } else { SUCCESS_INDICATOR = FALSE; } }"). :- pragma c_code(univ_type(Univ::in) = (TypeInfo::out), will_not_call_mercury, " TypeInfo = MR_field(MR_mktag(0), Univ, UNIV_OFFSET_FOR_TYPEINFO); "). :- pragma c_code(" MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(std_util, type_info, 0, MR_TYPECTOR_REP_C_POINTER); MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(std_util, univ, 0, MR_TYPECTOR_REP_UNIV); #ifndef COMPACT_ARGS Declare_label(mercury____Compare___std_util__univ_0_0_i1); MR_MAKE_PROC_LAYOUT(mercury____Compare___std_util__univ_0_0, MR_DETISM_DET, 1, MR_LONG_LVAL_STACKVAR(1), MR_PREDICATE, ""std_util"", ""compare_univ"", 3, 0); MR_MAKE_INTERNAL_LAYOUT(mercury____Compare___std_util__univ_0_0, 1); #endif Define_extern_entry(mercury____Unify___std_util__type_info_0_0); Define_extern_entry(mercury____Index___std_util__type_info_0_0); Define_extern_entry(mercury____Compare___std_util__type_info_0_0); BEGIN_MODULE(unify_univ_module) init_entry(mercury____Unify___std_util__univ_0_0); init_entry(mercury____Index___std_util__univ_0_0); init_entry(mercury____Compare___std_util__univ_0_0); init_entry(mercury____Unify___std_util__type_info_0_0); init_entry(mercury____Index___std_util__type_info_0_0); init_entry(mercury____Compare___std_util__type_info_0_0); BEGIN_CODE Define_entry(mercury____Unify___std_util__univ_0_0); { /* ** Unification for univ. ** ** The two inputs are in the registers named by unify_input[12]. ** The success/failure indication should go in unify_output. */ Word univ1, univ2; Word typeinfo1, typeinfo2; int comp; univ1 = r1; univ2 = r2; /* First check the type_infos compare equal */ typeinfo1 = MR_field(MR_mktag(0), univ1, UNIV_OFFSET_FOR_TYPEINFO); typeinfo2 = MR_field(MR_mktag(0), univ2, UNIV_OFFSET_FOR_TYPEINFO); save_transient_registers(); comp = MR_compare_type_info(typeinfo1, typeinfo2); restore_transient_registers(); if (comp != MR_COMPARE_EQUAL) { r1 = FALSE; proceed(); } /* ** Then invoke the generic unification predicate on the ** unwrapped args */ r1 = typeinfo1; r2 = MR_field(MR_mktag(0), univ1, UNIV_OFFSET_FOR_DATA); r3 = MR_field(MR_mktag(0), univ2, UNIV_OFFSET_FOR_DATA); { Declare_entry(mercury__unify_2_0); tailcall(ENTRY(mercury__unify_2_0), LABEL(mercury____Unify___std_util__univ_0_0)); } } Define_entry(mercury____Index___std_util__univ_0_0); r1 = -1; proceed(); Define_entry(mercury____Compare___std_util__univ_0_0); { /* ** Comparison for univ: ** ** The two inputs are in the registers named by compare_input[12]. ** The result should go in compare_output. */ Word univ1, univ2; Word typeinfo1, typeinfo2; int comp; univ1 = r1; univ2 = r2; /* First compare the type_infos */ typeinfo1 = MR_field(MR_mktag(0), univ1, UNIV_OFFSET_FOR_TYPEINFO); typeinfo2 = MR_field(MR_mktag(0), univ2, UNIV_OFFSET_FOR_TYPEINFO); save_transient_registers(); comp = MR_compare_type_info(typeinfo1, typeinfo2); restore_transient_registers(); if (comp != MR_COMPARE_EQUAL) { r1 = comp; proceed(); } /* ** If the types are the same, then invoke the generic compare/3 ** predicate on the unwrapped args. */ r1 = typeinfo1; r2 = MR_field(MR_mktag(0), univ1, UNIV_OFFSET_FOR_DATA); r3 = MR_field(MR_mktag(0), univ2, UNIV_OFFSET_FOR_DATA); { Declare_entry(mercury__compare_3_0); tailcall(ENTRY(mercury__compare_3_0), LABEL(mercury____Compare___std_util__univ_0_0)); } } Define_entry(mercury____Unify___std_util__type_info_0_0); { /* ** Unification for type_info. ** ** The two inputs are in the registers named by unify_input[12]. ** The success/failure indication should go in unify_output. */ int comp; save_transient_registers(); comp = MR_compare_type_info(r1, r2); restore_transient_registers(); r1 = (comp == MR_COMPARE_EQUAL); proceed(); } Define_entry(mercury____Index___std_util__type_info_0_0); r1 = -1; proceed(); Define_entry(mercury____Compare___std_util__type_info_0_0); { /* ** Comparison for type_info: ** ** The two inputs are in the registers named by compare_input[12]. ** The result should go in compare_output. */ int comp; save_transient_registers(); comp = MR_compare_type_info(r1, r2); restore_transient_registers(); r1 = comp; proceed(); } END_MODULE /* Ensure that the initialization code for the above module gets run. */ /* INIT sys_init_unify_univ_module */ MR_MODULE_STATIC_OR_EXTERN ModuleFunc unify_univ_module; void sys_init_unify_univ_module(void); /* suppress gcc -Wmissing-decl warning */ void sys_init_unify_univ_module(void) { unify_univ_module(); MR_INIT_TYPE_CTOR_INFO(mercury_data_std_util__type_ctor_info_univ_0, std_util__univ_0_0); MR_INIT_TYPE_CTOR_INFO(mercury_data_std_util__type_ctor_info_type_info_0, std_util__type_info_0_0); } "). %-----------------------------------------------------------------------------% % Code for type manipulation. % Prototypes and type definitions. :- pragma c_header_code(" typedef struct ML_Construct_Info_Struct { int vector_type; int arity; Word *functor_descriptor; Word *argument_vector; Word primary_tag; Word secondary_tag; ConstString functor_name; } ML_Construct_Info; int ML_get_num_functors(Word type_info); Word ML_copy_argument_typeinfos(int arity, Word type_info, Word *arg_vector); bool ML_get_functors_check_range(int functor_number, Word type_info, ML_Construct_Info *info); void ML_copy_arguments_from_list_to_vector(int arity, Word arg_list, Word term_vector); bool ML_typecheck_arguments(Word type_info, int arity, Word arg_list, Word* arg_vector); Word ML_make_type(int arity, MR_TypeCtorInfo type_ctor_info, Word arg_type_list); "). % A type_ctor_info is really just a subtype of type_info, % but we should hide this from users as it is an implementation % detail. :- type type_ctor_info == type_info. :- pragma c_code(type_of(_Value::unused) = (TypeInfo::out), will_not_call_mercury, " { TypeInfo = TypeInfo_for_T; /* ** We used to collapse equivalences for efficiency here, ** but that's not always desirable, due to the reverse ** mode of make_type/2, and efficiency of type_infos ** probably isn't very important anyway. */ #if 0 save_transient_registers(); TypeInfo = MR_collapse_equivalences(TypeInfo_for_T); restore_transient_registers(); #endif } "). :- pragma c_code(has_type(_Arg::unused, TypeInfo::in), will_not_call_mercury, " TypeInfo_for_T = TypeInfo; "). % Export this function in order to use it in runtime/mercury_trace_external.c :- pragma export(type_name(in) = out, "ML_type_name"). type_name(Type) = TypeName :- type_ctor_and_args(Type, TypeCtor, ArgTypes), type_ctor_name_and_arity(TypeCtor, ModuleName, Name, Arity), ( Arity = 0 -> UnqualifiedTypeName = Name ; ( ModuleName = "builtin", Name = "func" -> IsFunc = yes ; IsFunc = no ), ( IsFunc = yes, ArgTypes = [FuncRetType] -> FuncRetTypeName = type_name(FuncRetType), string__append_list( ["((func) = ", FuncRetTypeName, ")"], UnqualifiedTypeName) ; type_arg_names(ArgTypes, IsFunc, ArgTypeNames), string__append_list([Name, "(" | ArgTypeNames], UnqualifiedTypeName) ) ), ( ModuleName = "builtin" -> TypeName = UnqualifiedTypeName ; string__append_list([ModuleName, ":", UnqualifiedTypeName], TypeName) ). :- pred type_arg_names(list(type_info), bool, list(string)). :- mode type_arg_names(in, in, out) is det. type_arg_names([], _, []). type_arg_names([Type|Types], IsFunc, ArgNames) :- Name = type_name(Type), ( Types = [] -> ArgNames = [Name, ")"] ; IsFunc = yes, Types = [FuncReturnType] -> FuncReturnName = type_name(FuncReturnType), ArgNames = [Name, ") = ", FuncReturnName] ; type_arg_names(Types, IsFunc, Names), ArgNames = [Name, ", " | Names] ). type_args(Type) = ArgTypes :- type_ctor_and_args(Type, _TypeCtor, ArgTypes). type_ctor_name(TypeCtor) = Name :- type_ctor_name_and_arity(TypeCtor, _ModuleName, Name, _Arity). type_ctor_module_name(TypeCtor) = ModuleName :- type_ctor_name_and_arity(TypeCtor, ModuleName, _Name, _Arity). type_ctor_arity(TypeCtor) = Arity :- type_ctor_name_and_arity(TypeCtor, _ModuleName, _Name, Arity). det_make_type(TypeCtor, ArgTypes) = Type :- ( make_type(TypeCtor, ArgTypes) = NewType -> Type = NewType ; error("det_make_type/2: make_type/2 failed (wrong arity)") ). :- pragma c_code(type_ctor(TypeInfo::in) = (TypeCtor::out), will_not_call_mercury, " { MR_TypeCtorInfo type_ctor_info; Word *type_info; save_transient_registers(); type_info = (Word *) MR_collapse_equivalences(TypeInfo); restore_transient_registers(); type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info); TypeCtor = ML_make_ctor_info(type_info, type_ctor_info); } "). :- pragma c_header_code(" Word ML_make_ctor_info(Word *type_info, MR_TypeCtorInfo type_ctor_info); /* ** Several predicates use these (the MR_TYPE_CTOR_INFO_IS_HO_* ** macros need access to these addresses). */ MR_DECLARE_TYPE_CTOR_INFO_STRUCT(mercury_data___type_ctor_info_pred_0); MR_DECLARE_TYPE_CTOR_INFO_STRUCT(mercury_data___type_ctor_info_func_0); "). :- pragma c_code(" Word ML_make_ctor_info(Word *type_info, MR_TypeCtorInfo type_ctor_info) { Word ctor_info = (Word) type_ctor_info; if (MR_TYPE_CTOR_INFO_IS_HO_PRED(type_ctor_info)) { ctor_info = MR_TYPECTOR_MAKE_PRED( MR_TYPEINFO_GET_HIGHER_ARITY(type_info)); if (!MR_TYPECTOR_IS_HIGHER_ORDER(ctor_info)) { fatal_error(""std_util:ML_make_ctor_info"" ""- arity out of range.""); } } else if (MR_TYPE_CTOR_INFO_IS_HO_FUNC(type_ctor_info)) { ctor_info = MR_TYPECTOR_MAKE_FUNC( MR_TYPEINFO_GET_HIGHER_ARITY(type_info)); if (!MR_TYPECTOR_IS_HIGHER_ORDER(ctor_info)) { fatal_error(""std_util:ML_make_ctor_info"" ""- arity out of range.""); } } return ctor_info; } "). :- pragma c_code(type_ctor_and_args(TypeInfo::in, TypeCtor::out, TypeArgs::out), will_not_call_mercury, " { MR_TypeCtorInfo type_ctor_info; Word *type_info; Integer arity; save_transient_registers(); type_info = (Word *) MR_collapse_equivalences(TypeInfo); type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info); TypeCtor = ML_make_ctor_info(type_info, type_ctor_info); if (MR_TYPECTOR_IS_HIGHER_ORDER(TypeCtor)) { arity = MR_TYPECTOR_GET_HOT_ARITY(TypeCtor); TypeArgs = ML_copy_argument_typeinfos(arity, 0, type_info + TYPEINFO_OFFSET_FOR_PRED_ARGS); } else { arity = MR_TYPE_CTOR_INFO_GET_TYPE_ARITY(type_ctor_info); TypeArgs = ML_copy_argument_typeinfos(arity, 0, type_info + OFFSET_FOR_ARG_TYPE_INFOS); } restore_transient_registers(); } "). /* ** This is the forwards mode of make_type/2: ** given a type constructor and a list of argument ** types, check that the length of the argument ** types matches the arity of the type constructor, ** and if so, use the type constructor to construct ** a new type with the specified arguments. */ :- pragma c_code(make_type(TypeCtor::in, ArgTypes::in) = (Type::out), will_not_call_mercury, " { int list_length, arity; Word arg_type; MR_TypeCtorInfo type_ctor_info; type_ctor_info = (MR_TypeCtorInfo) TypeCtor; if (MR_TYPECTOR_IS_HIGHER_ORDER(type_ctor_info)) { arity = MR_TYPECTOR_GET_HOT_ARITY(type_ctor_info); } else { arity = MR_TYPE_CTOR_INFO_GET_TYPE_ARITY(type_ctor_info); } arg_type = ArgTypes; for (list_length = 0; !MR_list_is_empty(arg_type); list_length++) { arg_type = MR_list_tail(arg_type); } if (list_length != arity) { SUCCESS_INDICATOR = FALSE; } else { save_transient_registers(); Type = ML_make_type(arity, type_ctor_info, ArgTypes); restore_transient_registers(); SUCCESS_INDICATOR = TRUE; } } "). /* ** This is the reverse mode of make_type: given a type, ** split it up into a type constructor and a list of ** arguments. */ :- pragma c_code(make_type(TypeCtor::out, ArgTypes::out) = (TypeInfo::in), will_not_call_mercury, " { Word *type_info = (Word *) TypeInfo; MR_TypeCtorInfo type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info); Integer arity; TypeCtor = ML_make_ctor_info(type_info, type_ctor_info); if (MR_TYPECTOR_IS_HIGHER_ORDER(TypeCtor)) { arity = MR_TYPECTOR_GET_HOT_ARITY(type_ctor_info); save_transient_registers(); ArgTypes = ML_copy_argument_typeinfos(arity, 0, type_info + TYPEINFO_OFFSET_FOR_PRED_ARGS); restore_transient_registers(); } else { arity = MR_TYPE_CTOR_INFO_GET_TYPE_ARITY(type_ctor_info); save_transient_registers(); ArgTypes = ML_copy_argument_typeinfos(arity, 0, type_info + OFFSET_FOR_ARG_TYPE_INFOS); restore_transient_registers(); } } "). :- pragma c_code(type_ctor_name_and_arity(TypeCtor::in, TypeCtorModuleName::out, TypeCtorName::out, TypeCtorArity::out), will_not_call_mercury, " { MR_TypeCtorInfo type_ctor = (MR_TypeCtorInfo) TypeCtor; /* XXX zs: I think this code is wrong */ if (MR_TYPECTOR_IS_HIGHER_ORDER(type_ctor)) { TypeCtorModuleName = (String) (Word) MR_TYPECTOR_GET_HOT_MODULE_NAME(type_ctor); TypeCtorName = (String) (Word) MR_TYPECTOR_GET_HOT_NAME(type_ctor); TypeCtorArity = MR_TYPECTOR_GET_HOT_ARITY(type_ctor); } else { TypeCtorModuleName = type_ctor->type_ctor_module_name; TypeCtorName = type_ctor->type_ctor_name; TypeCtorArity = MR_TYPE_CTOR_INFO_GET_TYPE_ARITY(type_ctor); } } "). :- pragma c_code(num_functors(TypeInfo::in) = (Functors::out), will_not_call_mercury, " { save_transient_registers(); Functors = ML_get_num_functors(TypeInfo); restore_transient_registers(); } "). :- pragma c_code(get_functor(TypeInfo::in, FunctorNumber::in, FunctorName::out, Arity::out, TypeInfoList::out), will_not_call_mercury, " { ML_Construct_Info info; bool success; /* ** Get information for this functor number and ** store in info. If this is a discriminated union ** type and if the functor number is in range, we ** succeed. */ save_transient_registers(); success = ML_get_functors_check_range(FunctorNumber, TypeInfo, &info); restore_transient_registers(); /* ** Get the functor name and arity, construct the list ** of type_infos for arguments. */ if (success) { MR_make_aligned_string(FunctorName, (String) (Word) info.functor_name); Arity = info.arity; save_transient_registers(); TypeInfoList = ML_copy_argument_typeinfos((int) Arity, TypeInfo, info.argument_vector); restore_transient_registers(); } SUCCESS_INDICATOR = success; } "). :- pragma c_code(construct(TypeInfo::in, FunctorNumber::in, ArgList::in) = (Term::out), will_not_call_mercury, " { MR_TypeCtorInfo type_ctor_info; Word layout_entry, new_data, term_vector; ML_Construct_Info info; bool success; /* ** Check range of FunctorNum, get info for this ** functor. */ save_transient_registers(); success = ML_get_functors_check_range(FunctorNumber, TypeInfo, &info) && ML_typecheck_arguments(TypeInfo, info.arity, ArgList, info.argument_vector); restore_transient_registers(); /* ** Build the new term. ** ** It will be stored in `new_data', and `term_vector' is a ** the argument vector. ** */ if (success) { type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO( (Word *) TypeInfo); layout_entry = type_ctor_info->type_ctor_layout[ info.primary_tag]; if (info.vector_type == MR_TYPE_CTOR_FUNCTORS_ENUM) { /* ** Enumeratiors don't have tags or arguments, ** just the enumeration value. */ new_data = (Word) info.secondary_tag; } else { /* ** It must be some sort of tagged functor. */ if (info.vector_type == MR_TYPE_CTOR_FUNCTORS_NO_TAG) { /* ** We set term_vector to point to ** new_data so that the argument filling ** loop will fill the argument in. */ term_vector = (Word) &new_data; } else if (MR_tag(layout_entry) == TYPE_CTOR_LAYOUT_SHARED_REMOTE_TAG) { /* ** Create arity + 1 words, fill in the ** secondary tag, and the term_vector will ** be the rest of the words. */ incr_hp_msg(new_data, info.arity + 1, MR_PROC_LABEL, """"); MR_field(MR_mktag(0), new_data, 0) = info.secondary_tag; term_vector = (Word) (new_data + sizeof(Word)); } else if (MR_tag(layout_entry) == TYPE_CTOR_LAYOUT_CONST_TAG) { /* ** If it's a du, and this tag is ** constant, it must be a shared local ** tag. */ new_data = MR_mkbody(info.secondary_tag); term_vector = (Word) NULL; } else { /* ** An unshared tagged word, just need to ** create arguments. */ incr_hp_msg(new_data, info.arity, MR_PROC_LABEL, """"); term_vector = (Word) new_data; } /* ** Copy arguments. */ ML_copy_arguments_from_list_to_vector(info.arity, ArgList, term_vector); /* ** Add tag to new_data. */ new_data = (Word) MR_mkword(MR_mktag(info.primary_tag), new_data); } /* ** Create a univ. */ incr_hp_msg(Term, 2, MR_PROC_LABEL, ""std_util:univ/0""); MR_field(MR_mktag(0), Term, UNIV_OFFSET_FOR_TYPEINFO) = (Word) TypeInfo; MR_field(MR_mktag(0), Term, UNIV_OFFSET_FOR_DATA) = (Word) new_data; } SUCCESS_INDICATOR = success; } "). :- pragma c_code(" /* ** Prototypes */ static int ML_get_functor_info(Word type_info, int functor_number, ML_Construct_Info *info); /* ** ML_get_functor_info: ** ** Extract the information for functor number `functor_number', ** for the type represented by type_info. ** We succeed if the type is some sort of discriminated union. ** ** You need to save and restore transient registers around ** calls to this function. */ static int ML_get_functor_info(Word type_info, int functor_number, ML_Construct_Info *info) { MR_TypeCtorInfo type_ctor_info; Word *type_ctor_functors; type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO((Word *) type_info); if (! MR_type_ctor_rep_is_basically_du(type_ctor_info->type_ctor_rep)) { return FALSE; } type_ctor_functors = type_ctor_info->type_ctor_functors; info->vector_type = MR_TYPE_CTOR_FUNCTORS_INDICATOR(type_ctor_functors); switch (info->vector_type) { case MR_TYPE_CTOR_FUNCTORS_ENUM: info->functor_descriptor = MR_TYPE_CTOR_FUNCTORS_ENUM_VECTOR( type_ctor_functors); info->arity = 0; info->argument_vector = NULL; info->primary_tag = 0; info->secondary_tag = functor_number; info->functor_name = MR_TYPE_CTOR_LAYOUT_ENUM_VECTOR_FUNCTOR_NAME( info->functor_descriptor, functor_number); break; case MR_TYPE_CTOR_FUNCTORS_DU: info->functor_descriptor = MR_TYPE_CTOR_FUNCTORS_DU_FUNCTOR_N( type_ctor_functors, functor_number); info->arity = MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARITY( info->functor_descriptor); info->argument_vector = MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARGS( info->functor_descriptor); info->primary_tag = MR_tag( MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_TAG( info->functor_descriptor)); info->secondary_tag = MR_unmkbody( MR_body(MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_TAG( info->functor_descriptor), info->primary_tag)); info->functor_name = MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_FUNCTOR_NAME( info->functor_descriptor); break; case MR_TYPE_CTOR_FUNCTORS_NO_TAG: info->functor_descriptor = MR_TYPE_CTOR_FUNCTORS_NO_TAG_FUNCTOR( type_ctor_functors); info->arity = 1; info->argument_vector = MR_TYPE_CTOR_LAYOUT_NO_TAG_VECTOR_ARGS( info->functor_descriptor); info->primary_tag = 0; info->secondary_tag = 0; info->functor_name = MR_TYPE_CTOR_LAYOUT_NO_TAG_VECTOR_FUNCTOR_NAME( info->functor_descriptor); break; case MR_TYPE_CTOR_FUNCTORS_EQUIV: { Word *equiv_type; equiv_type = (Word *) MR_TYPE_CTOR_FUNCTORS_EQUIV_TYPE( type_ctor_functors); return ML_get_functor_info((Word) MR_create_type_info((Word *) type_info, equiv_type), functor_number, info); } case MR_TYPE_CTOR_FUNCTORS_SPECIAL: return FALSE; case MR_TYPE_CTOR_FUNCTORS_UNIV: return FALSE; default: fatal_error(""std_util:construct - unexpected type.""); } return TRUE; } /* ** ML_typecheck_arguments: ** ** Given a list of univs (`arg_list'), and a vector of ** type_infos (`arg_vector'), checks that they are all of the ** same type; if so, returns TRUE, otherwise returns FALSE; ** `arg_vector' may contain type variables, these ** will be filled in by the type arguments of `type_info'. ** ** Assumes the length of the list has already been checked. ** ** You need to save and restore transient registers around ** calls to this function. */ bool ML_typecheck_arguments(Word type_info, int arity, Word arg_list, Word* arg_vector) { int i, comp; Word arg_type_info, list_arg_type_info; /* Type check list of arguments */ for (i = 0; i < arity; i++) { if (MR_list_is_empty(arg_list)) { return FALSE; } list_arg_type_info = MR_field(MR_mktag(0), MR_list_head(arg_list), UNIV_OFFSET_FOR_TYPEINFO); arg_type_info = (Word) MR_create_type_info( (Word *) type_info, (Word *) arg_vector[i]); comp = MR_compare_type_info(list_arg_type_info, arg_type_info); if (comp != MR_COMPARE_EQUAL) { return FALSE; } arg_list = MR_list_tail(arg_list); } /* List should now be empty */ return MR_list_is_empty(arg_list); } /* ** ML_copy_arguments_from_list_to_vector: ** ** Copy the arguments from a list of univs (`arg_list'), ** into the vector (`term_vector'). ** ** Assumes the length of the list has already been checked. */ void ML_copy_arguments_from_list_to_vector(int arity, Word arg_list, Word term_vector) { int i; for (i = 0; i < arity; i++) { MR_field(MR_mktag(0), term_vector, i) = MR_field(MR_mktag(0), MR_list_head(arg_list), UNIV_OFFSET_FOR_DATA); arg_list = MR_list_tail(arg_list); } } /* ** ML_make_type(arity, type_ctor_info, arg_types_list): ** ** Construct and return a type_info for a type using the ** specified type_ctor for the type constructor, ** and using the arguments specified in arg_types_list ** for the type arguments (if any). ** ** Assumes that the arity of the type constructor represented ** by type_ctor_info and the length of the arg_types_list ** are both equal to `arity'. ** ** You need to save and restore transient registers around ** calls to this function. */ Word ML_make_type(int arity, MR_TypeCtorInfo type_ctor, Word arg_types_list) { int i, extra_args; Word type_ctor_info; /* ** We need to treat higher-order predicates as a special case here. */ if (MR_TYPECTOR_IS_HIGHER_ORDER(type_ctor)) { type_ctor_info = MR_TYPECTOR_GET_HOT_TYPE_CTOR_INFO(type_ctor); extra_args = 2; } else { type_ctor_info = (Word) type_ctor; extra_args = 1; } if (arity == 0) { return type_ctor_info; } else { Word *type_info; restore_transient_registers(); /* XXX should use incr_hp_msg() here */ incr_hp(LVALUE_CAST(Word, type_info), arity + extra_args); save_transient_registers(); MR_field(MR_mktag(0), type_info, 0) = type_ctor_info; if (MR_TYPECTOR_IS_HIGHER_ORDER(type_ctor)) { MR_field(MR_mktag(0), type_info, 1) = (Word) arity; } for (i = 0; i < arity; i++) { MR_field(MR_mktag(0), type_info, i + extra_args) = MR_list_head(arg_types_list); arg_types_list = MR_list_tail(arg_types_list); } return (Word) type_info; } } /* ** ML_get_functors_check_range: ** ** Check that functor_number is in range, and get the functor ** info if it is. Return FALSE if it is out of range, or ** if ML_get_functor_info returns FALSE, otherwise return TRUE. ** ** You need to save and restore transient registers around ** calls to this function. */ bool ML_get_functors_check_range(int functor_number, Word type_info, ML_Construct_Info *info) { /* ** Check range of functor_number, get functors ** vector */ return functor_number < ML_get_num_functors(type_info) && functor_number >= 0 && ML_get_functor_info(type_info, functor_number, info); } /* ** ML_copy_argument_typeinfos: ** ** Copy `arity' type_infos from `arg_vector' onto the heap ** in a list. ** ** You need to save and restore transient registers around ** calls to this function. */ Word ML_copy_argument_typeinfos(int arity, Word type_info, Word *arg_vector) { Word type_info_list, *functors; restore_transient_registers(); type_info_list = MR_list_empty(); while (--arity >= 0) { Word argument; /* Get the argument type_info */ argument = arg_vector[arity]; /* Fill in any polymorphic type_infos */ save_transient_registers(); argument = (Word) MR_create_type_info( (Word *) type_info, (Word *) argument); restore_transient_registers(); /* Look past any equivalences */ save_transient_registers(); argument = MR_collapse_equivalences(argument); restore_transient_registers(); /* Join the argument to the front of the list */ type_info_list = MR_list_cons(argument, type_info_list); } save_transient_registers(); return type_info_list; } /* ** ML_get_num_functors: ** ** Get the number of functors for a type. If it isn't a ** discriminated union, return -1. ** ** You need to save and restore transient registers around ** calls to this function. */ int ML_get_num_functors(Word type_info) { MR_TypeCtorInfo type_ctor_info; Word *type_ctor_functors; int functors; type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO((Word *) type_info); if (! MR_type_ctor_rep_is_basically_du(type_ctor_info->type_ctor_rep)) { return -1; } type_ctor_functors = type_ctor_info->type_ctor_functors; switch ((int) MR_TYPE_CTOR_FUNCTORS_INDICATOR(type_ctor_functors)) { case MR_TYPE_CTOR_FUNCTORS_DU: functors = MR_TYPE_CTOR_FUNCTORS_DU_NUM_FUNCTORS( type_ctor_functors); break; case MR_TYPE_CTOR_FUNCTORS_ENUM: functors = MR_TYPE_CTOR_FUNCTORS_ENUM_NUM_FUNCTORS( type_ctor_functors); break; case MR_TYPE_CTOR_FUNCTORS_EQUIV: { Word *equiv_type; equiv_type = (Word *) MR_TYPE_CTOR_FUNCTORS_EQUIV_TYPE( type_ctor_functors); functors = ML_get_num_functors((Word) MR_create_type_info((Word *) type_info, equiv_type)); break; } case MR_TYPE_CTOR_FUNCTORS_SPECIAL: functors = -1; break; case MR_TYPE_CTOR_FUNCTORS_NO_TAG: functors = 1; break; case MR_TYPE_CTOR_FUNCTORS_UNIV: functors = -1; break; default: fatal_error(""std_util:ML_get_num_functors :"" "" unknown indicator""); } return functors; } "). %-----------------------------------------------------------------------------% :- pragma c_header_code(" #include /* * Code for functor, arg and deconstruct * * This relies on some C primitives that take a type_info * and a data_word, and get a functor, arity, argument vector, * and argument type_info vector. */ /* Type definitions */ /* * The last two fields, need_functor, and need_args, must * be set by the caller, to indicate whether ML_expand * should copy the functor (if need_functor is non-zero) or * the argument vector and type_info_vector (if need_args is * non-zero). The arity will always be set. * * ML_expand will fill in the other fields (functor, arity, * argument_vector, type_info_vector, and non_canonical_type) * accordingly, but * the values of fields not asked for should be assumed to * contain random data when ML_expand returns. * (that is, they should not be relied on to remain unchanged). */ typedef struct ML_Expand_Info_Struct { ConstString functor; int arity; int num_extra_args; Word *argument_vector; Word *type_info_vector; bool non_canonical_type; bool need_functor; bool need_args; } ML_Expand_Info; /* Prototypes */ void ML_expand(Word* type_info, Word *data_word_ptr, ML_Expand_Info *info); /* NB. ML_arg() is also used by store__arg_ref in store.m */ bool ML_arg(Word term_type_info, Word *term, Word argument_index, Word *arg_type_info, Word **argument_ptr); "). :- pragma c_code(" Declare_entry(mercury__builtin_compare_pred_3_0); Declare_entry(mercury__builtin_compare_non_canonical_type_3_0); /* ** Expand the given data using its type_info, find its ** functor, arity, argument vector and type_info vector. ** ** The info.type_info_vector is allocated using MR_GC_malloc(). ** (We need to use MR_GC_malloc() rather than MR_malloc() or malloc(), ** since this vector may contain pointers into the Mercury heap, and ** memory allocated with MR_malloc() or malloc() will not be traced by the ** Boehm collector.) ** It is the responsibility of the caller to deallocate this ** memory (using MR_GC_free()), and to copy any fields of this vector to ** the Mercury heap. The type_infos that the elements of ** this vector point to are either ** - already allocated on the heap. ** - constants (eg type_ctor_infos) ** ** Please note: ** ML_expand increments the heap pointer, however, on ** some platforms the register windows mean that transient ** Mercury registers may be lost. Before calling ML_expand, ** call save_transient_registers(), and afterwards, call ** restore_transient_registers(). ** ** If writing a C function that calls deep_copy, make sure you ** document that around your function, save_transient_registers() ** restore_transient_registers() need to be used. ** ** If you change this code you will also have reflect any changes in ** runtime/mercury_deep_copy.c and runtime/mercury_table_any.c ** ** We use 4 space tabs here because of the level of indenting. */ void ML_expand(Word* type_info, Word *data_word_ptr, ML_Expand_Info *info) { MR_TypeCtorInfo type_ctor_info; MR_TypeCtorLayout type_ctor_layout; MR_TypeCtorFunctors type_ctor_functors; Code *compare_pred; Word layout_for_tag; Word layout_vector_for_tag; Word data_value; Word data_word; int data_tag; MR_DiscUnionTagRepresentation tag_rep; type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info); type_ctor_layout = type_ctor_info->type_ctor_layout; type_ctor_functors = type_ctor_info->type_ctor_functors; compare_pred = type_ctor_info->compare_pred; info->non_canonical_type = ( compare_pred == ENTRY(mercury__builtin_compare_non_canonical_type_3_0) ); data_word = *data_word_ptr; data_tag = MR_tag(data_word); data_value = MR_body(data_word, data_tag); switch(type_ctor_info->type_ctor_rep) { case MR_TYPECTOR_REP_ENUM: case MR_TYPECTOR_REP_ENUM_USEREQ: layout_for_tag = type_ctor_layout[data_tag]; layout_vector_for_tag = MR_strip_tag(layout_for_tag); info->functor = MR_TYPE_CTOR_LAYOUT_ENUM_VECTOR_FUNCTOR_NAME( layout_vector_for_tag, data_word); info->arity = 0; info->num_extra_args = 0; info->argument_vector = NULL; info->type_info_vector = NULL; break; case MR_TYPECTOR_REP_DU: case MR_TYPECTOR_REP_DU_USEREQ: layout_for_tag = type_ctor_layout[data_tag]; layout_vector_for_tag = MR_strip_tag(layout_for_tag); tag_rep = MR_get_tag_representation((Word) layout_for_tag); switch (tag_rep) { case MR_DISCUNIONTAG_SHARED_LOCAL: data_value = MR_unmkbody(data_value); info->functor = MR_TYPE_CTOR_LAYOUT_ENUM_VECTOR_FUNCTOR_NAME( layout_vector_for_tag, data_value); info->arity = 0; info->num_extra_args = 0; info->argument_vector = NULL; info->type_info_vector = NULL; break; case MR_DISCUNIONTAG_SHARED_REMOTE: { Word secondary_tag; secondary_tag = ((Word *) data_value)[0]; /* ** Look past the secondary tag, and get the functor ** descriptor, then we can just use the code for ** unshared tags. */ data_value = (Word) ((Word *) data_value + 1); layout_for_tag = (Word) MR_TYPE_CTOR_LAYOUT_SHARED_REMOTE_VECTOR_GET_FUNCTOR_DESCRIPTOR( layout_vector_for_tag, secondary_tag); layout_vector_for_tag = MR_strip_tag(layout_for_tag); } /* fallthru */ case MR_DISCUNIONTAG_UNSHARED: /* fallthru */ { int i; Word * functor_descriptor = (Word *) layout_vector_for_tag; info->arity = MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARITY(functor_descriptor); info->num_extra_args = MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_EXIST_VARCOUNT(functor_descriptor); if (info->need_functor) { MR_make_aligned_string(info->functor, MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_FUNCTOR_NAME( functor_descriptor)); } if (info->need_args) { info->argument_vector = (Word *) data_value; info->type_info_vector = MR_GC_NEW_ARRAY(Word, info->arity); for (i = 0; i < info->arity ; i++) { Word *arg_pseudo_type_info; arg_pseudo_type_info = (Word *) MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARGS( functor_descriptor)[i]; info->type_info_vector[i] = (Word) MR_create_type_info_maybe_existq( type_info, arg_pseudo_type_info, (Word *) data_value, functor_descriptor); } } break; } } break; case MR_TYPECTOR_REP_NOTAG: case MR_TYPECTOR_REP_NOTAG_USEREQ: { int i; Word * functor_descriptor; layout_for_tag = type_ctor_layout[data_tag]; layout_vector_for_tag = MR_strip_tag(layout_for_tag); functor_descriptor = (Word *) layout_vector_for_tag; data_value = (Word) data_word_ptr; info->arity = MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARITY( functor_descriptor); info->num_extra_args = 0; if (info->need_functor) { MR_make_aligned_string(info->functor, MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_FUNCTOR_NAME( functor_descriptor)); } if (info->need_args) { /* * A NO_TAG is much like UNSHARED, but we use the * data_word_ptr here to simulate an argument * vector. */ info->argument_vector = (Word *) data_word_ptr; info->type_info_vector = MR_GC_NEW_ARRAY(Word, info->arity); for (i = 0; i < info->arity ; i++) { Word *arg_pseudo_type_info; arg_pseudo_type_info = (Word *) MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARGS( functor_descriptor)[i]; info->type_info_vector[i] = (Word) MR_create_type_info_maybe_existq( type_info, arg_pseudo_type_info, (Word *) data_value, functor_descriptor); } } break; } case MR_TYPECTOR_REP_EQUIV: { Word *equiv_type_info; layout_for_tag = type_ctor_layout[data_tag]; layout_vector_for_tag = MR_strip_tag(layout_for_tag); equiv_type_info = MR_create_type_info(type_info, (Word *) MR_TYPE_CTOR_LAYOUT_EQUIV_TYPE(layout_vector_for_tag)); ML_expand(equiv_type_info, data_word_ptr, info); break; } case MR_TYPECTOR_REP_EQUIV_VAR: { Word *equiv_type_info; layout_for_tag = type_ctor_layout[data_tag]; layout_vector_for_tag = MR_strip_tag(layout_for_tag); equiv_type_info = MR_create_type_info(type_info, (Word *) layout_vector_for_tag); ML_expand(equiv_type_info, data_word_ptr, info); break; } case MR_TYPECTOR_REP_INT: if (info->need_functor) { char buf[500]; char *str; sprintf(buf, ""%ld"", (long) data_word); incr_saved_hp_atomic(LVALUE_CAST(Word, str), (strlen(buf) + sizeof(Word)) / sizeof(Word)); strcpy(str, buf); info->functor = str; } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_CHAR: /* XXX should escape characters correctly */ if (info->need_functor) { char *str; incr_saved_hp_atomic(LVALUE_CAST(Word, str), (3 + sizeof(Word)) / sizeof(Word)); sprintf(str, ""\'%c\'"", (char) data_word); info->functor = str; } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_FLOAT: if (info->need_functor) { char buf[500]; Float f; char *str; f = word_to_float(data_word); sprintf(buf, ""%#.15g"", f); incr_saved_hp_atomic(LVALUE_CAST(Word, str), (strlen(buf) + sizeof(Word)) / sizeof(Word)); strcpy(str, buf); info->functor = str; } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_STRING: /* XXX should escape characters correctly */ if (info->need_functor) { char *str; incr_saved_hp_atomic(LVALUE_CAST(Word, str), (strlen((String) data_word) + 2 + sizeof(Word)) / sizeof(Word)); sprintf(str, ""%c%s%c"", '""', (String) data_word, '""'); info->functor = str; } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_PRED: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_UNIV: /* * Univ is a two word structure, containing * type_info and data. */ ML_expand((Word *) ((Word *) data_word)[UNIV_OFFSET_FOR_TYPEINFO], &((Word *) data_word)[UNIV_OFFSET_FOR_DATA], info); break; case MR_TYPECTOR_REP_VOID: /* ** There's no way to create values of type `void', ** so this should never happen. */ fatal_error(""ML_expand: cannot expand void types""); case MR_TYPECTOR_REP_C_POINTER: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_TYPEINFO: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } /* XXX should we return the arguments here? */ info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_TYPECLASSINFO: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } /* XXX should we return the arguments here? */ info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_ARRAY: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } /* XXX should we return the arguments here? */ info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_SUCCIP: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_HP: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_CURFR: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_MAXFR: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_REDOFR: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_REDOIP: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_TRAIL_PTR: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_TICKET: if (info->need_functor) { MR_make_aligned_string(info->functor, ""<>""); } info->argument_vector = NULL; info->type_info_vector = NULL; info->arity = 0; info->num_extra_args = 0; break; case MR_TYPECTOR_REP_UNKNOWN: /* fallthru */ default: fatal_error(""ML_expand: cannot expand -- unknown data type""); break; } } /* ** ML_arg() is a subroutine used to implement arg/2, argument/2, ** and also store__arg_ref/5 in store.m. ** It takes a term (& its type), and an argument index, ** and returns a */ bool ML_arg(Word term_type_info, Word *term_ptr, Word argument_index, Word *arg_type_info, Word **argument_ptr) { ML_Expand_Info info; Word arg_pseudo_type_info; bool success; info.need_functor = FALSE; info.need_args = TRUE; ML_expand((Word *) term_type_info, term_ptr, &info); /* ** Check for attempts to deconstruct a non-canonical type: ** such deconstructions must be cc_multi, and since ** arg/2 is det, we must treat violations of this ** as runtime errors. ** (There ought to be a cc_multi version of arg/2 ** that allows this.) */ if (info.non_canonical_type) { fatal_error(""called argument/2 for a type with a "" ""user-defined equality predicate""); } /* Check range */ success = (argument_index >= 0 && argument_index < info.arity); if (success) { /* figure out the type of the argument */ arg_pseudo_type_info = info.type_info_vector[argument_index]; if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info)) { *arg_type_info = ((Word *) term_type_info)[arg_pseudo_type_info]; } else { *arg_type_info = arg_pseudo_type_info; } *argument_ptr = &info.argument_vector[argument_index]; } /* ** Free the allocated type_info_vector, since we just copied ** the stuff we want out of it. */ MR_GC_free(info.type_info_vector); return success; } "). %-----------------------------------------------------------------------------% % Code for functor, arg and deconstruct. :- pragma c_code(functor(Term::in, Functor::out, Arity::out), will_not_call_mercury, " { ML_Expand_Info info; info.need_functor = TRUE; info.need_args = FALSE; save_transient_registers(); ML_expand((Word *) TypeInfo_for_T, &Term, &info); restore_transient_registers(); /* ** Check for attempts to deconstruct a non-canonical type: ** such deconstructions must be cc_multi, and since ** functor/2 is det, we must treat violations of this ** as runtime errors. ** (There ought to be a cc_multi version of functor/2 ** that allows this.) */ if (info.non_canonical_type) { fatal_error(""called functor/2 for a type with a "" ""user-defined equality predicate""); } /* Copy functor onto the heap */ MR_make_aligned_string(LVALUE_CAST(ConstString, Functor), info.functor); Arity = info.arity; }"). /* ** N.B. any modifications to arg/2 might also require similar ** changes to store__arg_ref in store.m. */ :- pragma c_code(arg(Term::in, ArgumentIndex::in) = (Argument::out), will_not_call_mercury, " { Word arg_type_info; Word *argument_ptr; bool success; int comparison_result; save_transient_registers(); success = ML_arg(TypeInfo_for_T, &Term, ArgumentIndex, &arg_type_info, &argument_ptr); if (success) { /* compare the actual type with the expected type */ comparison_result = MR_compare_type_info(arg_type_info, TypeInfo_for_ArgT); success = (comparison_result == MR_COMPARE_EQUAL); if (success) { Argument = *argument_ptr; } } restore_transient_registers(); SUCCESS_INDICATOR = success; }"). :- pragma c_code(argument(Term::in, ArgumentIndex::in) = (ArgumentUniv::out), will_not_call_mercury, " { Word arg_type_info; Word *argument_ptr; bool success; save_transient_registers(); success = ML_arg(TypeInfo_for_T, &Term, ArgumentIndex, &arg_type_info, &argument_ptr); restore_transient_registers(); if (success) { /* Allocate enough room for a univ */ incr_hp_msg(ArgumentUniv, 2, MR_PROC_LABEL, ""std_util:univ/0""); MR_field(MR_mktag(0), ArgumentUniv, UNIV_OFFSET_FOR_TYPEINFO) = arg_type_info; MR_field(MR_mktag(0), ArgumentUniv, UNIV_OFFSET_FOR_DATA) = *argument_ptr; } SUCCESS_INDICATOR = success; }"). det_arg(Type, ArgumentIndex) = Argument :- ( arg(Type, ArgumentIndex) = Argument0 -> Argument = Argument0 ; ( argument(Type, ArgumentIndex) = _ArgumentUniv -> error("det_arg: argument number out of range") ; error("det_arg: argument had wrong type") ) ). det_argument(Type, ArgumentIndex) = Argument :- ( argument(Type, ArgumentIndex) = Argument0 -> Argument = Argument0 ; error("det_argument: argument out of range") ). :- pragma c_code(deconstruct(Term::in, Functor::out, Arity::out, Arguments::out), will_not_call_mercury, " { ML_Expand_Info info; Word arg_pseudo_type_info; Word Argument, tmp; int i; info.need_functor = TRUE; info.need_args = TRUE; save_transient_registers(); ML_expand((Word *) TypeInfo_for_T, &Term, &info); restore_transient_registers(); /* ** Check for attempts to deconstruct a non-canonical type: ** such deconstructions must be cc_multi, and since ** deconstruct/4 is det, we must treat violations of this ** as runtime errors. ** (There ought to be a cc_multi version of deconstruct/4 ** that allows this.) */ if (info.non_canonical_type) { fatal_error(""called deconstruct/4 for a type with a "" ""user-defined equality predicate""); } /* Get functor */ MR_make_aligned_string(LVALUE_CAST(ConstString, Functor), info.functor); /* Get arity */ Arity = info.arity; /* Build argument list */ Arguments = MR_list_empty_msg(MR_PROC_LABEL); i = info.arity; while (--i >= 0) { /* Create an argument on the heap */ incr_hp_msg(Argument, 2, MR_PROC_LABEL, ""std_util:univ/0""); /* Join the argument to the front of the list */ Arguments = MR_list_cons_msg(Argument, Arguments, MR_PROC_LABEL); /* Fill in the arguments */ arg_pseudo_type_info = info.type_info_vector[i]; if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info)) { /* It's a type variable, get its value */ MR_field(MR_mktag(0), Argument, UNIV_OFFSET_FOR_TYPEINFO) = ((Word *) TypeInfo_for_T)[arg_pseudo_type_info]; } else { /* It's already a type_info */ MR_field(MR_mktag(0), Argument, UNIV_OFFSET_FOR_TYPEINFO) = arg_pseudo_type_info; } /* Fill in the data */ MR_field(MR_mktag(0), Argument, UNIV_OFFSET_FOR_DATA) = info.argument_vector[i + info.num_extra_args]; } /* Free the allocated type_info_vector, since we just copied * all its arguments onto the heap. */ MR_GC_free(info.type_info_vector); }"). %-----------------------------------------------------------------------------% % This predicate returns the type_info for the type std_util:type_info. % It is intended for use from C code, since Mercury code can access % this type_info easily enough even without this predicate. :- pred get_type_info_for_type_info(type_info). :- mode get_type_info_for_type_info(out) is det. :- pragma export(get_type_info_for_type_info(out), "ML_get_type_info_for_type_info"). get_type_info_for_type_info(TypeInfo) :- Type = type_of(1), TypeInfo = type_of(Type). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% % Ralph Becket 24/04/99 % Function forms added. :- interface. :- func pair(T1, T2) = pair(T1, T2). :- func maybe_func(func(T1) = T2, T1) = maybe(T2). :- mode maybe_func(func(in) = out is semidet, in) = out is det. % General purpose higher-order programming constructs. % compose(F, G, X) = F(G(X)) % % Function composition. % XXX It would be nice to have infix `o' or somesuch for this. :- func compose(func(T2) = T3, func(T1) = T2, T1) = T3. % converse(F, X, Y) = F(Y, X) :- func converse(func(T1, T2) = T3, T2, T1) = T3. % pow(F, N, X) = F^N(X) % % Function exponentiation. :- func pow(func(T) = T, int, T) = T. % ---------------------------------------------------------------------------- % % ---------------------------------------------------------------------------- % :- implementation. pair(X, Y) = X-Y. maybe_func(PF, X) = ( if Y = PF(X) then yes(Y) else no ). compose(F, G, X) = F(G(X)). converse(F, X, Y) = F(Y, X). pow(F, N, X) = ( if N = 0 then X else pow(F, N - 1, F(X)) ).