[m-dev.] [reuse] diff: move alias-handling of pragma_foreign_code to other place
Nancy Mazur
Nancy.Mazur at cs.kuleuven.ac.be
Tue Oct 17 04:48:45 AEDT 2000
Hi,
===================================================================
Estimated hours taken: 0.5
Move the heuristics for handling pragma_foreign_code to pa_alias_as
as a separate predicate (just like the handling of the unifications
is left to pa_alias_as.m).
pa_alias_as.m:
pa_run.m:
Move the handling of the pragma_foreign_code to
a new predicate pa_alias_as__extend_foreign_code/7.
pa_util.m:
Move some code from pa_run to here so that it can be used
by pa_alias_as.
sr_indirect.m:
Handle pragma_foreign_code similarly to the alias run.
Index: pa_alias_as.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/Attic/pa_alias_as.m,v
retrieving revision 1.1.2.4
diff -u -r1.1.2.4 pa_alias_as.m
--- pa_alias_as.m 2000/10/16 09:03:49 1.1.2.4
+++ pa_alias_as.m 2000/10/16 17:42:39
@@ -11,7 +11,7 @@
:- interface.
-%-------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%-- import_module
% library modules
@@ -26,12 +26,12 @@
:- import_module sr_live.
:- import_module pa_datastruct.
-%-------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%-- exported types
:- type alias_as.
-%-------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%-- exported predicates
:- pred init( alias_as::out ) is det.
@@ -98,6 +98,11 @@
hlds_goal__hlds_goal_info, alias_as, alias_as).
:- mode extend_unification( in, in, in, in, in, out) is det.
+:- pred extend_foreign_code( proc_info, module_info,
+ list(prog_var), list(maybe(pair(string, mode))),
+ list(type), alias_as, alias_as).
+:- mode extend_foreign_code( in, in, in, in, in, in, out) is det.
+
% Add two abstract substitutions to each other. These
% abstract substitutions come from different contexts, and have
% not to be 'extended' wrt each other.
@@ -146,17 +151,17 @@
:- func size( alias_as ) = int.
:- mode size( in ) = out is det.
-%-------------------------------------------------------------------%
-%-------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- implementation.
% library modules
:- import_module require.
% compiler modules
-:- import_module pa_alias.
+:- import_module pa_alias, pa_util.
-%-------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%-- type definitions
:- type alias_as --->
@@ -168,7 +173,7 @@
% where string could be some sort of message.
-%-------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
% init
init(bottom).
@@ -393,6 +398,7 @@
).
+%-----------------------------------------------------------------------------%
extend_unification( ProcInfo, HLDS, Unif, GoalInfo, ASin, ASout ):-
pa_alias__from_unification( ProcInfo, HLDS, Unif, GoalInfo, AUnif),
wrap(AUnif, ASUnif),
@@ -440,6 +446,127 @@
does_not_contain_vars( Vars, Alias) :-
not contains_one_of_vars_in_list( Vars, Alias).
+
+%-----------------------------------------------------------------------------%
+extend_foreign_code( _ProcInfo, HLDS, Vars, MaybeModes, Types, Alias0, Alias):-
+ to_trios(Vars, MaybeModes, Types, Trios),
+ % remove all unique objects
+ remove_all_unique_vars( HLDS, Trios, NonUniqueVars),
+ % keep only the output vars
+ collect_all_output_vars( HLDS, NonUniqueVars, OutputVars),
+ collect_all_input_vars( HLDS, NonUniqueVars, InputVars),
+ (
+ (
+ OutputVars = []
+ ;
+ % XXXXXXXXXXXXXXXXX !!
+ OutputVars = [_], InputVars = []
+ )
+ ->
+ Alias = Alias0
+ ;
+ list__map(
+ pred( Trio::in, Type::out ) is det:-
+ (
+ Trio = trio(_, _, Type)
+ ),
+ OutputVars,
+ OutputTypes),
+ (
+ types_are_primitive( HLDS, OutputTypes)
+ ->
+ Alias = Alias0
+ ;
+ pa_alias_as__top("pragma_c_code not handled", Alias)
+ )
+ ).
+
+
+:- import_module std_util, inst_match.
+
+:- type trio ---> trio( prog_var, mode, type).
+
+:- pred to_trios( list(prog_var), list(maybe(pair(string, mode))),
+ list(type), list(trio)).
+:- mode to_trios( in, in, in, out) is det.
+
+to_trios( Vars, MaybeModes, Types, Trios ):-
+ (
+ Vars = [ V1 | VR ]
+ ->
+ (
+ MaybeModes = [ M1 | MR ],
+ Types = [ T1 | TR ]
+ ->
+ (
+ M1 = yes( _String - Mode )
+ ->
+ Trio1 = trio( V1, Mode, T1),
+ to_trios( VR, MR, TR, TrioR),
+ Trios = [ Trio1 | TrioR ]
+ ;
+ to_trios( VR, MR, TR, Trios )
+ )
+ ;
+ require__error("(pa_run) to_trios: lists of different length.")
+ )
+ ;
+ (
+ MaybeModes = [], Types = []
+ ->
+ Trios = []
+ ;
+ require__error("(pa_run) to_trios: not all lists empty.")
+ )
+ ).
+
+:- pred collect_all_output_vars( module_info::in,
+ list(trio)::in, list(trio)::out) is det.
+:- pred remove_all_unique_vars( module_info::in,
+ list(trio)::in, list(trio)::out) is det.
+:- pred collect_all_input_vars( module_info::in,
+ list(trio)::in, list(trio)::out) is det.
+
+:- import_module mode_util.
+
+collect_all_output_vars( HLDS, VarsIN, VarsOUT):-
+ list__filter(
+ pred( P0::in ) is semidet :-
+ (
+ P0 = trio(_, Mode, Type),
+ mode_to_arg_mode(HLDS, Mode, Type, ArgMode),
+ ArgMode = top_out
+ ),
+ VarsIN,
+ VarsOUT
+ ).
+
+remove_all_unique_vars( HLDS, VarsIN, VarsOUT):-
+ list__filter(
+ pred( P0::in ) is semidet :-
+ (
+ P0 = trio(_, Mode, _),
+ Mode = (_LeftInst -> RightInst),
+ \+ inst_is_unique(HLDS, RightInst),
+ \+ inst_is_clobbered(HLDS, RightInst)
+ ),
+ VarsIN,
+ VarsOUT
+ ).
+
+collect_all_input_vars( HLDS, VarsIN, VarsOUT):-
+ list__filter(
+ pred( P0::in ) is semidet :-
+ (
+ P0 = trio(_, Mode, Type),
+ mode_to_arg_mode(HLDS, Mode, Type, ArgMode),
+ ArgMode = top_in
+ ),
+ VarsIN,
+ VarsOUT
+ ).
+
+%-----------------------------------------------------------------------------%
normalize( ProcInfo, HLDS, _INSTMAP, ALIASin, ALIASout):-
% normalize only using type-info's
Index: pa_run.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/Attic/pa_run.m,v
retrieving revision 1.1.2.6
diff -u -r1.1.2.6 pa_run.m
--- pa_run.m 2000/10/13 15:30:35 1.1.2.6
+++ pa_run.m 2000/10/16 17:42:40
@@ -359,39 +359,10 @@
pa_alias_as__least_upper_bound( ProcInfo, HLDS, A2, A3, A).
analyse_goal_expr( pragma_foreign_code( _,_,_,_, Vars, MaybeModes,Types,_ ),
- _Info, _, HLDS ,
+ _Info, ProcInfo, HLDS ,
T, T, Ain, A) :-
- to_trios(Vars, MaybeModes, Types, Trios),
- % remove all unique objects
- remove_all_unique_vars( HLDS, Trios, NonUniqueVars),
- % keep only the output vars
- collect_all_output_vars( HLDS, NonUniqueVars, OutputVars),
- collect_all_input_vars( HLDS, NonUniqueVars, InputVars),
- (
- (
- OutputVars = []
- ;
- % XXXXXXXXXXXXXXXXX !!
- OutputVars = [_], InputVars = []
- )
- ->
- A = Ain
- ;
- list__map(
- pred( Trio::in, Type::out ) is det:-
- (
- Trio = trio(_, _, Type)
- ),
- OutputVars,
- OutputTypes),
- (
- types_are_primitive( HLDS, OutputTypes)
- ->
- A = Ain
- ;
- pa_alias_as__top("pragma_c_code not handled", A)
- )
- ).
+ pa_alias_as__extend_foreign_code( ProcInfo, HLDS, Vars,
+ MaybeModes, Types, Ain, A).
% error( "(pa) pragma_c_code not handled") .
analyse_goal_expr( par_conj( _Goals, _SM), _Info, _, _ , T, T, _A, A) :-
@@ -403,94 +374,6 @@
%-----------------------------------------------------------------------------%
-
-
-:- import_module std_util, inst_match.
-
-:- type trio ---> trio( prog_var, mode, type).
-
-:- pred to_trios( list(prog_var), list(maybe(pair(string, mode))),
- list(type), list(trio)).
-:- mode to_trios( in, in, in, out) is det.
-
-to_trios( Vars, MaybeModes, Types, Trios ):-
- (
- Vars = [ V1 | VR ]
- ->
- (
- MaybeModes = [ M1 | MR ],
- Types = [ T1 | TR ]
- ->
- (
- M1 = yes( _String - Mode )
- ->
- Trio1 = trio( V1, Mode, T1),
- to_trios( VR, MR, TR, TrioR),
- Trios = [ Trio1 | TrioR ]
- ;
- to_trios( VR, MR, TR, Trios )
- )
- ;
- require__error("(pa_run) to_trios: lists of different length.")
- )
- ;
- (
- MaybeModes = [], Types = []
- ->
- Trios = []
- ;
- require__error("(pa_run) to_trios: not all lists empty.")
- )
- ).
-
-:- pred collect_all_output_vars( module_info::in,
- list(trio)::in, list(trio)::out) is det.
-:- pred remove_all_unique_vars( module_info::in,
- list(trio)::in, list(trio)::out) is det.
-:- pred collect_all_input_vars( module_info::in,
- list(trio)::in, list(trio)::out) is det.
-
-:- import_module mode_util.
-
-collect_all_output_vars( HLDS, VarsIN, VarsOUT):-
- list__filter(
- pred( P0::in ) is semidet :-
- (
- P0 = trio(_, Mode, Type),
- mode_to_arg_mode(HLDS, Mode, Type, ArgMode),
- ArgMode = top_out
- ),
- VarsIN,
- VarsOUT
- ).
-
-remove_all_unique_vars( HLDS, VarsIN, VarsOUT):-
- list__filter(
- pred( P0::in ) is semidet :-
- (
- P0 = trio(_, Mode, _),
- Mode = (_LeftInst -> RightInst),
- \+ inst_is_unique(HLDS, RightInst),
- \+ inst_is_clobbered(HLDS, RightInst)
- ),
- VarsIN,
- VarsOUT
- ).
-
-collect_all_input_vars( HLDS, VarsIN, VarsOUT):-
- list__filter(
- pred( P0::in ) is semidet :-
- (
- P0 = trio(_, Mode, Type),
- mode_to_arg_mode(HLDS, Mode, Type, ArgMode),
- ArgMode = top_in
- ),
- VarsIN,
- VarsOUT
- ).
-
-%-----------------------------------------------------------------------------%
-
% lookup the alias of the procedure with given pred_proc_id and
% find it's output abstract substitution.
% 1 - look first in table, if this fails (then not in same SCC)
@@ -592,29 +475,6 @@
ErrMsg),
top(ErrMsg, Alias)
).
-
-:- import_module type_util.
-
-:- pred arg_types_are_all_primitive(module_info, pred_info).
-:- mode arg_types_are_all_primitive(in,in) is semidet.
-
-arg_types_are_all_primitive(HLDS, PredInfo):-
- hlds_pred__pred_info_arg_types(PredInfo, ArgTypes),
- types_are_primitive( HLDS, ArgTypes).
-
-:- pred types_are_primitive( module_info::in, list(type)::in) is semidet.
-
-types_are_primitive( HLDS, TYPES ) :-
- list__filter( pred( TYPE::in ) is semidet :-
- (
- type_util__type_is_atomic(TYPE,HLDS)
- ),
- TYPES,
- _TrueList,
- [] ).
-
-
-
:- pred rename_call_alias( pred_proc_id, module_info, list(prog_var),
alias_as, alias_as).
Index: pa_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/Attic/pa_util.m,v
retrieving revision 1.1.2.2
diff -u -r1.1.2.2 pa_util.m
--- pa_util.m 2000/10/12 15:03:44 1.1.2.2
+++ pa_util.m 2000/10/16 17:42:40
@@ -12,7 +12,7 @@
:- interface.
-%-------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- import_module hlds_pred.
:- import_module pa_alias_as.
@@ -57,8 +57,8 @@
:- mode pa_fixpoint_table_get_final_as( in, out, in) is det.
-%-------------------------------------------------------------------%
-%-------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- implementation.
:- type pa_fixpoint_table ==
@@ -93,4 +93,34 @@
pa_fixpoint_table_get_final_as( PRED_PROC_ID, ALIAS_AS, T ):-
fp_get_final( PRED_PROC_ID, ALIAS_AS, T).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- interface.
+
+:- import_module hlds_module, hlds_pred, list.
+:- import_module prog_data.
+
+:- pred arg_types_are_all_primitive(module_info, pred_info).
+:- mode arg_types_are_all_primitive(in,in) is semidet.
+
+:- pred types_are_primitive( module_info::in, list(type)::in) is semidet.
+
+:- implementation.
+
+:- import_module type_util.
+
+arg_types_are_all_primitive(HLDS, PredInfo):-
+ hlds_pred__pred_info_arg_types(PredInfo, ArgTypes),
+ types_are_primitive( HLDS, ArgTypes).
+
+types_are_primitive( HLDS, TYPES ) :-
+ list__filter( pred( TYPE::in ) is semidet :-
+ (
+ type_util__type_is_atomic(TYPE,HLDS)
+ ),
+ TYPES,
+ _TrueList,
+ [] ).
Index: sr_indirect.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/Attic/sr_indirect.m,v
retrieving revision 1.1.2.6
diff -u -r1.1.2.6 sr_indirect.m
--- sr_indirect.m 2000/10/16 17:19:12 1.1.2.6
+++ sr_indirect.m 2000/10/16 17:42:42
@@ -423,11 +423,12 @@
Expr = if_then_else( Vars, Cond, Then, Else, SM),
Goal = Expr - Info.
-analyse_goal( _ProcInfo, _HLDS, Expr0 - Info0, Goal, Pool0, Pool,
- _Alias0, Alias,
+analyse_goal( ProcInfo, _HLDS, Expr0 - Info0, Goal, Pool0, Pool,
+ Alias0, Alias,
FP0, FP) :-
- Expr0 = pragma_foreign_code( _, _, _, _, _, _, _, _ ),
- pa_alias_as__top("unhandled goal", Alias),
+ Expr0 = pragma_foreign_code( _, _, _, _, Vars, MaybeModes, Types, _ ),
+ pa_alias_as__extend_foreign_code( ProcInfo, HLDS, Vars,
+ MaybeModes, Types, Alias0, Alias),
Pool = Pool0,
FP = FP0,
Goal = Expr0 - Info0.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list