[m-rev.] diff: allow :- externals and foreign_procs to be backend-specific
Zoltan Somogyi
zs at cs.mu.OZ.AU
Mon Mar 7 16:41:09 AEDT 2005
Provide a mechanism to allow a predicate to be defined as a foreign_proc for
one backend and as external for another backend. The intended use is to
implement builtin_catch in exception.m, which cannot be implemented as a
foreign_proc for hlc grades, but whose implementation as external for the
LLDS grades requires handwriting extremely error-prone code and data structures
that the compiler could generate reliably.
The mechanism is two language extensions. One allows :- external declarations
such as
:- external(high_level_backend, p/3).
The second allows foreign_procs such as
:- pragma foreign_proc("C",
p(N::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure, low_level_backend],
...
compiler/prog_data.m:
Add an extra field to the items for `:- external' declarations to
allow hold the optional backend designation.
Add an extra optional attribute to foreign_procs to handle the
backend designation.
compiler/prog_io_pragma.m:
Change the code for reading external declarations to handle the new
attribute.
compiler/prog_io_pragma.m:
Change the code for reading foreign_proc attributes to handle the new
attribute.
compiler/make_hlds.m:
Ignore external declarations and foreign_proc definitions if they are
for the wrong backend.
Use state variables in a place that can benefit from it.
compiler/hlds_module.m:
Clean up some formatting.
compiler/equiv_type.m:
compiler/ml_code_gen.m:
compiler/module_qual.m:
compiler/modules.m:
Conform to the changed data structures in prog_data.
doc/reference_manual.texi:
Add commented-out documentation of the extension to foreign_procs.
There is no existing documentation of :- external to update.
tests/hard_coded/backend_external.{m,exp,exp2}:
New test case for the new language extensions.
tests/hard_coded/Mmakefile:
Enable the new test case.
Zoltan.
cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/equiv_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/equiv_type.m,v
retrieving revision 1.42
diff -u -b -r1.42 equiv_type.m
--- compiler/equiv_type.m 21 Jan 2005 03:27:37 -0000 1.42
+++ compiler/equiv_type.m 23 Feb 2005 13:25:10 -0000
@@ -194,7 +194,7 @@
is_section_defn(abstract_imported) = yes.
is_section_defn(opt_imported) = yes.
is_section_defn(transitively_imported) = yes.
-is_section_defn(external(_)) = no.
+is_section_defn(external(_, _)) = no.
is_section_defn(export(_)) = no.
is_section_defn(import(_)) = no.
is_section_defn(use(_)) = no.
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.109
diff -u -b -r1.109 hlds_module.m
--- compiler/hlds_module.m 15 Feb 2005 05:22:17 -0000 1.109
+++ compiler/hlds_module.m 23 Feb 2005 13:25:11 -0000
@@ -94,8 +94,8 @@
% specializations, and a list of predicates which should be
% processed by higher_order.m to ensure the production of those
% versions.
-:- type type_spec_info
- ---> type_spec_info(
+:- type type_spec_info --->
+ type_spec_info(
set(pred_proc_id), % Procedures for which there are
% user-requested type specializations.
set(pred_id), % Set of procedures which need to be
@@ -1397,38 +1397,42 @@
:- type predicate_table --->
predicate_table(
- preds :: pred_table, % map from pred_id to
- % pred_info
- next_pred_id :: pred_id, % next available pred_id
- pred_ids :: list(pred_id), % the keys of the
- % pred_table - cached
+ preds :: pred_table,
+ % map from pred_id to pred_info
+
+ next_pred_id :: pred_id,
+ % next available pred_id
+
+ pred_ids :: list(pred_id),
+ % the keys of the pred_table - cached
% here for efficiency
+
accessibility_table :: accessibility_table,
- % How is the predicate
- % accessible?
+ % How is the predicate accessible?
% indexes on predicates
- pred_name_index :: name_index, % map from pred name
- % to pred_id
+ pred_name_index :: name_index,
+ % map from pred name to pred_id
+
pred_name_arity_index :: name_arity_index,
- % map from pred name &
- % arity to pred_id
+ % map from pred name & arity to pred_id
+
pred_module_name_arity_index :: module_name_arity_index,
- % map from pred module,
- % name & arity to
- % pred_id
+ % map from pred module, name & arity
+ % to pred_id
% indexes on functions
- func_name_index :: name_index, % map from func name
- % to pred_id
+
+ func_name_index :: name_index,
+ % map from func name to pred_id
+
func_name_arity_index :: name_arity_index,
- % map from func name &
- % arity to pred_id
+ % map from func name & arity to pred_id
+
func_module_name_arity_index :: module_name_arity_index
- % map from func module,
- % name & arity to
- % pred_id
+ % map from func module, name & arity
+ % to pred_id
).
:- type accessibility_table == map(pred_id, name_accessibility).
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.500
diff -u -b -r1.500 make_hlds.m
--- compiler/make_hlds.m 24 Feb 2005 06:07:08 -0000 1.500
+++ compiler/make_hlds.m 24 Feb 2005 21:05:58 -0000
@@ -438,10 +438,22 @@
)
; ModuleDefn = include_module(_) ->
true
- ; ModuleDefn = external(External) ->
+ ; ModuleDefn = external(MaybeBackend, External) ->
( External = name_arity(Name, Arity) ->
+ lookup_current_backend(CurrentBackend, !IO),
+ (
+ (
+ MaybeBackend = no
+ ;
+ MaybeBackend = yes(Backend),
+ Backend = CurrentBackend
+ )
+ ->
module_mark_as_external(Name, Arity, Context, !ModuleInfo, !IO)
;
+ true
+ )
+ ;
prog_out__write_context(Context, !IO),
report_warning("Warning: `external' declaration requires arity.\n",
!IO)
@@ -5081,10 +5093,8 @@
globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
(
VeryVerbose = yes,
- io__write_string("% Processing `:- pragma foreign_proc' for ",
- !IO),
- hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity,
- !IO),
+ io__write_string("% Processing `:- pragma foreign_proc' for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
io__write_string("...\n", !IO)
;
VeryVerbose = no
@@ -5095,11 +5105,10 @@
% Lookup the pred declaration in the predicate table.
% (If it's not there, print an error message and insert
% a dummy declaration for the predicate.)
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
+ module_info_get_predicate_table(!.ModuleInfo, PredTable0),
(
- predicate_table_search_pf_sym_arity(PredicateTable0,
- is_fully_qualified, PredOrFunc, PredName,
- Arity, [PredId0])
+ predicate_table_search_pf_sym_arity(PredTable0, is_fully_qualified,
+ PredOrFunc, PredName, Arity, [PredId0])
->
PredId = PredId0
;
@@ -5108,28 +5117,30 @@
"`:- pragma foreign_proc' declaration",
PredId, !ModuleInfo, !IO)
),
- % Lookup the pred_info for this pred,
- % add the pragma to the proc_info in the proc_table in the
- % pred_info, and save the pred_info.
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable1),
- predicate_table_get_preds(PredicateTable1, Preds0),
- map__lookup(Preds0, PredId, PredInfo0),
+
+ % Lookup the pred_info for this pred, add the pragma to the proc_info
+ % in the proc_table in the pred_info, and save the pred_info.
+ module_info_get_predicate_table(!.ModuleInfo, PredTable1),
+ predicate_table_get_preds(PredTable1, Preds0),
+ some [!PredInfo] (
+ map__lookup(Preds0, PredId, !:PredInfo),
+ PredInfo0 = !.PredInfo,
+
% opt_imported preds are initially tagged as imported and are
% tagged as opt_imported only if/when we see a clause (including
% a `pragma c_code' clause) for them
( Status = opt_imported ->
- pred_info_set_import_status(opt_imported,
- PredInfo0, PredInfo1a)
+ pred_info_set_import_status(opt_imported, !PredInfo)
;
- PredInfo1a = PredInfo0
+ true
),
(
% If this procedure was previously defined as clauses only
% then we need to turn all the non mode-specific clauses
% into mode-specific clauses.
- pred_info_clause_goal_type(PredInfo1a)
+ pred_info_clause_goal_type(!.PredInfo)
->
- pred_info_clauses_info(PredInfo1a, CInfo0),
+ pred_info_clauses_info(!.PredInfo, CInfo0),
clauses_info_clauses(CInfo0, ClauseList0),
ClauseList = list__map(
(func(C) =
@@ -5138,15 +5149,22 @@
;
C
) :-
- AllProcIds = pred_info_all_procids(PredInfo1a)
+ AllProcIds = pred_info_all_procids(!.PredInfo)
), ClauseList0),
clauses_info_set_clauses(ClauseList, CInfo0, CInfo),
- pred_info_set_clauses_info(CInfo, PredInfo1a, PredInfo1)
+ pred_info_set_clauses_info(CInfo, !PredInfo)
;
- PredInfo1 = PredInfo1a
+ true
),
+ lookup_current_backend(CurrentBackend, !IO),
(
- pred_info_is_imported(PredInfo1)
+ ExtraAttrs = extra_attributes(Attributes),
+ is_applicable_for_current_backend(CurrentBackend, ExtraAttrs) = no
+ ->
+ % Ignore this foreign_proc.
+ true
+ ;
+ pred_info_is_imported(!.PredInfo)
->
module_info_incr_errors(!ModuleInfo),
prog_out__write_context(Context, !IO),
@@ -5161,52 +5179,44 @@
% than the ones we can generate code for.
not list__member(PragmaForeignLanguage, BackendForeignLangs)
->
- pred_info_update_goal_type(pragmas, PredInfo0, PredInfo),
- module_info_set_pred_info(PredId, PredInfo, !ModuleInfo)
+ pred_info_update_goal_type(pragmas, PredInfo0, !:PredInfo),
+ module_info_set_pred_info(PredId, !.PredInfo, !ModuleInfo)
;
% add the pragma declaration to the proc_info for this procedure
- pred_info_procedures(PredInfo1, Procs),
+ pred_info_procedures(!.PredInfo, Procs),
map__to_assoc_list(Procs, ExistingProcs),
pragma_get_modes(PVars, Modes),
(
get_procedure_matching_argmodes(ExistingProcs, Modes,
!.ModuleInfo, ProcId)
->
- pred_info_clauses_info(PredInfo1, Clauses0),
-
- pred_info_arg_types(PredInfo1, ArgTypes),
- pred_info_get_purity(PredInfo1, Purity),
- clauses_info_add_pragma_foreign_proc(Purity,
- Attributes, PredId, ProcId, VarSet, PVars,
- ArgTypes, PragmaImpl, Context, PredOrFunc,
- PredName, Arity, Clauses0, Clauses,
+ pred_info_clauses_info(!.PredInfo, Clauses0),
+ pred_info_arg_types(!.PredInfo, ArgTypes),
+ pred_info_get_purity(!.PredInfo, Purity),
+ clauses_info_add_pragma_foreign_proc(Purity, Attributes,
+ PredId, ProcId, VarSet, PVars, ArgTypes, PragmaImpl,
+ Context, PredOrFunc, PredName, Arity, Clauses0, Clauses,
!ModuleInfo, !IO),
- pred_info_set_clauses_info(Clauses,
- PredInfo1, PredInfo2),
- pred_info_update_goal_type(pragmas,
- PredInfo2, PredInfo),
- map__det_update(Preds0, PredId, PredInfo, Preds),
- predicate_table_set_preds(Preds,
- PredicateTable1, PredicateTable),
- module_info_set_predicate_table(PredicateTable,
- !ModuleInfo),
+ pred_info_set_clauses_info(Clauses, !PredInfo),
+ pred_info_update_goal_type(pragmas, !PredInfo),
+ map__det_update(Preds0, PredId, !.PredInfo, Preds),
+ predicate_table_set_preds(Preds, PredTable1, PredTable),
+ module_info_set_predicate_table(PredTable, !ModuleInfo),
pragma_get_var_infos(PVars, ArgInfo),
- maybe_warn_pragma_singletons(PragmaImpl,
- PragmaForeignLanguage, ArgInfo,
- Context, PredOrFunc - PredName/Arity,
+ maybe_warn_pragma_singletons(PragmaImpl, PragmaForeignLanguage,
+ ArgInfo, Context, PredOrFunc - PredName/Arity,
!.ModuleInfo, !IO)
;
module_info_incr_errors(!ModuleInfo),
prog_out__write_context(Context, !IO),
- io__write_string("Error: `:- pragma foreign_proc' ",
- !IO),
- io__write_string("declaration for undeclared mode ",
- !IO),
+ io__write_string("Error: `:- pragma foreign_proc' ", !IO),
+ io__write_string("declaration for undeclared mode ", !IO),
io__write_string("of ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc,
- PredName/Arity, !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity,
+ !IO),
io__write_string(".\n", !IO)
)
+ )
).
%-----------------------------------------------------------------------------%
@@ -6313,29 +6323,26 @@
PVarSet, PVars, OrigArgTypes, PragmaImpl0, Context, PredOrFunc,
PredName, Arity, !ClausesInfo, !ModuleInfo, !IO) :-
- !.ClausesInfo = clauses_info(VarSet0, VarTypes, TVarNameMap,
- VarTypes1, HeadVars, ClauseList, TI_VarMap, TCI_VarMap,
+ !.ClausesInfo = clauses_info(VarSet0, ExplicitVarTypes, TVarNameMap,
+ InferredVarTypes, HeadVars, ClauseList, TI_VarMap, TCI_VarMap,
_HasForeignClauses),
% Find all the existing clauses for this mode, and
% extract their implementation language and clause number
% (that is, their index in the list).
- NewLang = foreign_language(Attributes0),
-
globals__io_get_globals(Globals, !IO),
globals__io_get_target(Target, !IO),
-
- list__foldl2(decide_action(Globals, Target, NewLang, ProcId),
- ClauseList, add, FinalAction, 1, _),
+ NewLang = foreign_language(Attributes0),
+ list__foldl2(decide_action(Globals, Target, NewLang, ProcId), ClauseList,
+ add, FinalAction, 1, _),
globals__io_get_backend_foreign_languages(BackendForeignLanguages, !IO),
pragma_get_vars(PVars, Args0),
pragma_get_var_infos(PVars, ArgInfo),
%
- % If the foreign language not one of the backend
- % languages, we will have to generate an interface to it in a
- % backend language.
+ % If the foreign language not one of the backend languages, we will
+ % have to generate an interface to it in a backend language.
%
foreign__extrude_pragma_implementation(BackendForeignLanguages,
PVars, PredName, PredOrFunc, Context, !ModuleInfo,
@@ -6410,9 +6417,38 @@
NewClauseList = [NewClause | NewClauseListTail]
),
HasForeignClauses = yes,
- !:ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap,
- VarTypes1, HeadVars, NewClauseList,
+ !:ClausesInfo = clauses_info(VarSet, ExplicitVarTypes, TVarNameMap,
+ InferredVarTypes, HeadVars, NewClauseList,
TI_VarMap, TCI_VarMap, HasForeignClauses)
+ ).
+
+:- func is_applicable_for_current_backend(backend,
+ list(pragma_foreign_proc_extra_attribute)) = bool.
+
+is_applicable_for_current_backend(_CurrentBackend, []) = yes.
+is_applicable_for_current_backend(CurrentBackend, [Attr | Attrs]) = Result :-
+ (
+ Attr = max_stack_size(_),
+ Result = is_applicable_for_current_backend(CurrentBackend, Attrs)
+ ;
+ Attr = backend(Backend),
+ ( Backend = CurrentBackend ->
+ Result = is_applicable_for_current_backend(CurrentBackend, Attrs)
+ ;
+ Result = no
+ )
+ ).
+
+:- pred lookup_current_backend(backend::out, io::di, io::uo) is det.
+
+lookup_current_backend(CurrentBackend, !IO) :-
+ globals__io_lookup_bool_option(highlevel_code, HighLevel, !IO),
+ (
+ HighLevel = yes,
+ CurrentBackend = high_level_backend
+ ;
+ HighLevel= no,
+ CurrentBackend = low_level_backend
).
% As we traverse the clauses, at each one decide which action to perform.
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.147
diff -u -b -r1.147 ml_code_gen.m
--- compiler/ml_code_gen.m 21 Jan 2005 03:27:40 -0000 1.147
+++ compiler/ml_code_gen.m 23 Feb 2005 13:44:42 -0000
@@ -2953,9 +2953,11 @@
pragma_foreign_proc_extra_attributes) = target_code_attributes.
get_target_code_attributes(_, []) = [].
-get_target_code_attributes(Lang, [max_stack_size(N) | Xs]) =
+get_target_code_attributes(Lang, [backend(_Backend) | Attrs]) =
+ get_target_code_attributes(Lang, Attrs).
+get_target_code_attributes(Lang, [max_stack_size(N) | Attrs]) =
( Lang = il ->
- [max_stack_size(N) | get_target_code_attributes(Lang, Xs)]
+ [max_stack_size(N) | get_target_code_attributes(Lang, Attrs)]
;
[]
).
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.96
diff -u -b -r1.96 module_qual.m
--- compiler/module_qual.m 21 Jan 2005 03:27:44 -0000 1.96
+++ compiler/module_qual.m 23 Feb 2005 13:25:13 -0000
@@ -361,7 +361,7 @@
mq_info_set_need_qual_flag(Info1, must_be_qualified, Info).
process_module_defn(transitively_imported, _, _) :-
error("process_module_defn: transitively_imported item").
-process_module_defn(external(_), Info, Info).
+process_module_defn(external(_, _), Info, Info).
process_module_defn(end_module(_), Info, Info).
process_module_defn(export(_), Info, Info).
process_module_defn(import(Imports), Info0, Info) :-
@@ -712,7 +712,7 @@
mq_info_set_import_status(Info0, local, Info).
update_import_status(imported(_), Info, Info, no).
update_import_status(used(_), Info, Info, no).
-update_import_status(external(_), Info, Info, yes).
+update_import_status(external(_, _), Info, Info, yes).
update_import_status(end_module(_), Info, Info, yes).
update_import_status(export(_), Info, Info, yes).
update_import_status(import(_), Info, Info, yes).
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.318
diff -u -b -r1.318 modules.m
--- compiler/modules.m 24 Feb 2005 00:22:49 -0000 1.318
+++ compiler/modules.m 24 Feb 2005 09:39:23 -0000
@@ -1551,7 +1551,7 @@
ModuleDefn = transitively_imported,
!:Unexpected = yes
;
- ModuleDefn = external(_),
+ ModuleDefn = external(_, _),
!:Unexpected = yes
;
ModuleDefn = export(_),
@@ -7238,7 +7238,7 @@
include_in_int_file_implementation(type_defn(_, _, _, _, _)).
include_in_int_file_implementation(module_defn(_, Defn)) :-
- Defn \= external(_).
+ Defn \= external(_, _).
% `:- typeclass declarations' may be referred to
% by the constructors in type declarations.
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.119
diff -u -b -r1.119 prog_data.m
--- compiler/prog_data.m 24 Feb 2005 06:07:10 -0000 1.119
+++ compiler/prog_data.m 24 Feb 2005 21:26:01 -0000
@@ -1012,7 +1012,8 @@
% exception otherwise.
:- type pragma_foreign_proc_extra_attribute
- ---> max_stack_size(int).
+ ---> max_stack_size(int)
+ ; backend(backend).
:- type pragma_foreign_proc_extra_attributes ==
list(pragma_foreign_proc_extra_attribute).
@@ -1561,7 +1562,7 @@
% applies to all of the following items in the list,
% not just up to the next pseudo-declaration.
- ; external(sym_name_specifier)
+ ; external(maybe(backend), sym_name_specifier)
; export(sym_list)
; import(sym_list)
@@ -1574,6 +1575,10 @@
% smart recompilation.
; version_numbers(module_name, recompilation__version_numbers).
+:- type backend
+ ---> high_level_backend
+ ; low_level_backend.
+
:- type section
---> implementation
; interface.
@@ -1785,6 +1790,8 @@
:- func extra_attribute_to_string(pragma_foreign_proc_extra_attribute)
= string.
+extra_attribute_to_string(backend(low_level_backend)) = "low_level_backend".
+extra_attribute_to_string(backend(high_level_backend)) = "high_level_backend".
extra_attribute_to_string(max_stack_size(Size)) =
"max_stack_size(" ++ string__int_to_string(Size) ++ ")".
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.236
diff -u -b -r1.236 prog_io.m
--- compiler/prog_io.m 7 Feb 2005 11:41:05 -0000 1.236
+++ compiler/prog_io.m 5 Mar 2005 16:57:12 -0000
@@ -1260,11 +1260,25 @@
Result0 = ok(module_defn(VarSet, implementation)),
check_no_attributes(Result0, Attributes, Result).
-process_decl(ModuleName, VarSet, "external", [PredSpec], Attributes,
- Result) :-
+process_decl(ModuleName, VarSet, "external", Args, Attributes, Result) :-
+ (
+ Args = [PredSpec],
+ MaybeBackend = no
+ ;
+ Args = [BackendArg, PredSpec],
+ BackendArg = term__functor(term__atom(Functor), [], _),
+ (
+ Functor = "high_level_backend",
+ Backend = high_level_backend
+ ;
+ Functor = "low_level_backend",
+ Backend = low_level_backend
+ ),
+ MaybeBackend = yes(Backend)
+ ),
parse_implicitly_qualified_symbol_name_specifier(ModuleName,
PredSpec, Result0),
- process_maybe1(make_external(VarSet), Result0, Result1),
+ process_maybe1(make_external(VarSet, MaybeBackend), Result0, Result1),
check_no_attributes(Result1, Attributes, Result).
process_decl(DefaultModuleName, VarSet0, "module", [ModuleName], Attributes,
@@ -1490,9 +1504,11 @@
type_defn(VarSet, Name, Args, TypeDefn, Cond)) :-
varset__coerce(VarSet0, VarSet).
-:- pred make_external(varset::in, sym_name_specifier::in, item::out) is det.
+:- pred make_external(varset::in, maybe(backend)::in, sym_name_specifier::in,
+ item::out) is det.
-make_external(VarSet0, SymSpec, module_defn(VarSet, external(SymSpec))) :-
+make_external(VarSet0, MaybeBackend, SymSpec,
+ module_defn(VarSet, external(MaybeBackend, SymSpec))) :-
varset__coerce(VarSet0, VarSet).
:- pred get_is_solver_type(is_solver_type::out,
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.78
diff -u -b -r1.78 prog_io_pragma.m
--- compiler/prog_io_pragma.m 24 Feb 2005 06:07:10 -0000 1.78
+++ compiler/prog_io_pragma.m 24 Feb 2005 21:06:00 -0000
@@ -1273,6 +1273,7 @@
; purity(purity)
; aliasing
; max_stack_size(int)
+ ; backend(backend)
; terminates(terminates)
; will_not_throw_exception
; ordinary_despite_detism.
@@ -1356,6 +1357,8 @@
set_may_throw_exception(will_not_throw_exception, !Attrs).
process_attribute(max_stack_size(Size), !Attrs) :-
add_extra_attribute(max_stack_size(Size), !Attrs).
+process_attribute(backend(Backend), !Attrs) :-
+ add_extra_attribute(backend(Backend), !Attrs).
process_attribute(ordinary_despite_detism, !Attrs) :-
set_ordinary_despite_detism(yes, !Attrs).
@@ -1414,6 +1417,8 @@
Flag = aliasing
; parse_max_stack_size(Term, Size) ->
Flag = max_stack_size(Size)
+ ; parse_backend(Term, Backend) ->
+ Flag = backend(Backend)
; parse_purity_promise(Term, Purity) ->
Flag = purity(Purity)
; parse_terminates(Term, Terminates) ->
@@ -1478,6 +1483,17 @@
parse_max_stack_size(term__functor(
term__atom("max_stack_size"), [SizeTerm], _), Size) :-
SizeTerm = term__functor(term__integer(Size), [], _).
+
+:- pred parse_backend(term::in, backend::out) is semidet.
+
+parse_backend(term__functor(term__atom(Functor), [], _), Backend) :-
+ (
+ Functor = "high_level_backend",
+ Backend = high_level_backend
+ ;
+ Functor = "low_level_backend",
+ Backend = low_level_backend
+ ).
:- pred parse_purity_promise(term::in, purity::out) is semidet.
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.308
diff -u -b -r1.308 reference_manual.texi
--- doc/reference_manual.texi 24 Feb 2005 06:07:11 -0000 1.308
+++ doc/reference_manual.texi 7 Mar 2005 01:50:02 -0000
@@ -5790,6 +5790,10 @@
these types may also throw exceptions. As such, we recommend that
only implementors of the Mercury system use this annotation for
polymorphic predicates and functions.
+ at c @item @samp{high_level_backend}
+ at c The foreign_proc will apply only on the high level backend.
+ at c @item @samp{low_level_backend}
+ at c The foreign_proc will apply only on the low level backend.
@end table
@c -----------------------------------------------------------------------
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.249
diff -u -b -r1.249 Mmakefile
--- tests/hard_coded/Mmakefile 3 Feb 2005 08:14:37 -0000 1.249
+++ tests/hard_coded/Mmakefile 23 Feb 2005 09:17:40 -0000
@@ -9,6 +9,7 @@
address_of_builtins \
agg \
any_free_unify \
+ backend_external \
backquoted_qualified_ops \
bidirectional \
boyer \
@@ -169,8 +170,8 @@
test_imported_no_tag \
time_test \
tim_qual1 \
- trans_intermod_user_equality \
transform_value \
+ trans_intermod_user_equality \
transitive_inst_type \
tuple_test \
tuple_test \
Index: tests/hard_coded/backend_external.m
===================================================================
RCS file: tests/hard_coded/backend_external.m
diff -N tests/hard_coded/backend_external.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/backend_external.m 23 Feb 2005 14:27:21 -0000
@@ -0,0 +1,106 @@
+:- module backend_external.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+main(!IO) :-
+ p(1, !IO),
+ q(2, !IO).
+
+ % external in llds grades, foreign_proc in mlds grades
+:- pred p(int::in, io::di, io::uo) is det.
+
+ % foreign_proc in llds grades, external in mlds grades
+:- pred q(int::in, io::di, io::uo) is det.
+
+:- external(low_level_backend, p/3).
+:- external(high_level_backend, q/3).
+
+:- pragma foreign_proc("C",
+ p(N::in, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure, high_level_backend],
+"
+#ifdef MR_HIGHLEVEL_CODE
+ printf(""p(%d): expected highlevel, found highlevel, OK\\n"", N);
+#else
+ printf(""p(%d): expected highlevel, found lowlevel, BUG\\n"", N);
+#endif
+
+ IO = IO0;
+").
+
+:- pragma foreign_proc("C",
+ q(N::in, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure, low_level_backend],
+"
+#ifdef MR_HIGHLEVEL_CODE
+ printf(""q(%d): expected lowlevel, found highlevel, BUG\\n"", N);
+#else
+ printf(""q(%d): expected lowlevel, found lowlevel, OK\\n"", N);
+#endif
+
+ IO = IO0;
+").
+
+:- pragma foreign_code("C",
+"
+#ifdef MR_HIGHLEVEL_CODE
+
+void MR_CALL
+mercury__backend_external__q_3_p_0(MR_Integer n)
+{
+ printf(""q(%d): expected highlevel, found highlevel, OK\\n"", n);
+}
+
+#else
+
+MR_define_extern_entry(mercury__backend_external__p_3_0);
+
+MR_BEGIN_MODULE(backend_external_module)
+ MR_init_entry(mercury__backend_external__p_3_0);
+MR_BEGIN_CODE
+MR_define_entry(mercury__backend_external__p_3_0);
+ printf(""p(%d): expected lowlevel, found lowlevel, OK\\n"", MR_r1);
+ MR_proceed();
+MR_END_MODULE
+
+/* Ensure that the initialization code for the above module gets run. */
+/*
+INIT mercury_sys_init_backend_external_module
+*/
+
+extern void
+mercury_sys_init_backend_external_module_init(void);
+
+extern void
+mercury_sys_init_backend_external_module_init_type_tables(void);
+
+extern void
+mercury_sys_init_backend_external_module_write_out_proc_statics(FILE *fp);
+
+void
+mercury_sys_init_backend_external_module_init(void)
+{
+#ifndef MR_HIGHLEVEL_CODE
+ backend_external_module();
+#endif
+}
+
+void
+mercury_sys_init_backend_external_module_init_type_tables(void)
+{
+ /* no types to register */
+}
+
+void
+mercury_sys_init_backend_external_module_write_out_proc_statics(FILE *fp)
+{
+}
+
+#endif
+").
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------
More information about the reviews
mailing list