[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