From 3c7c6f7c31e2cb876a866f88b3e70c19c3be8ff4 Mon Sep 17 00:00:00 2001 From: Tom Schrijvers Date: Wed, 13 Feb 2008 15:07:01 +0100 Subject: [PATCH] clean-up of CHR compiler --- chr_translate.chr | 173 ++++++++++++++++++++---------------------------------- 1 file changed, 63 insertions(+), 110 deletions(-) diff --git a/chr_translate.chr b/chr_translate.chr index 5f9cc5b..3254b28 100644 --- a/chr_translate.chr +++ b/chr_translate.chr @@ -3800,8 +3800,7 @@ specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :- unalias_type(Type,NormalType), memberchk_eq(NormalType,[int,natural]) -> ( NormalType == int -> - Hash = abs(Key), - Call = true + Call = (Hash is abs(Key)) ; Hash = Key, Call = true @@ -3891,32 +3890,19 @@ actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Inde % % Returns predicate name of hash table lookup predicate. multi_hash_lookup_name(F/A,Index,Name) :- - ( integer(Index) -> - IndexName = Index - ; is_list(Index) -> - atom_concat_list(Index,IndexName) - ), + atom_concat_list(Index,IndexName), atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name). multi_hash_store_name(F/A,Index,Name) :- get_target_module(Mod), - ( integer(Index) -> - IndexName = Index - ; is_list(Index) -> - atom_concat_list(Index,IndexName) - ), + atom_concat_list(Index,IndexName), atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name). multi_hash_key(FA,Index,Susp,KeyBody,Key) :- - ( ( integer(Index) -> - I = Index - ; - Index = [I] - ) -> + ( Index = [I] -> get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody) - ; is_list(Index) -> - sort(Index,Indexes), - maplist(get_dynamic_suspension_term_field1(FA,Susp),Indexes,Keys,Bodies), + ; + maplist(get_dynamic_suspension_term_field1(FA,Susp),Index,Keys,Bodies), Key =.. [k|Keys], list2conj(Bodies,KeyBody) ). @@ -3925,15 +3911,10 @@ get_dynamic_suspension_term_field1(FA,Susp,I,KeyI,Goal) :- get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal). multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :- - ( ( integer(Index) -> - I = Index - ; - Index = [I] - ) -> + ( Index = [I] -> get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,I,Key,KeyBody) - ; is_list(Index) -> - sort(Index,Indexes), - maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Indexes,Keys,Bodies), + ; + maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Index,Keys,Bodies), Key =.. [k|Keys], list2conj(Bodies,KeyBody) ). @@ -3949,27 +3930,15 @@ get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Arg,Goal) :- ). multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :- - ( ( integer(Index) -> - I = Index - ; - Index = [I] - ) -> + ( Index = [I] -> UsedVars = [I-Key] - ; is_list(Index) -> - sort(Index,Indexes), - pairup(Indexes,Keys,UsedVars), + ; + pairup(Index,Keys,UsedVars), Key =.. [k|Keys] ). multi_hash_key_args(Index,Head,KeyArgs) :- - ( integer(Index) -> - arg(Index,Head,Arg), - KeyArgs = [Arg] - ; is_list(Index) -> - sort(Index,Indexes), - term_variables(Head,Vars), - maplist(arg1(Head),Indexes,KeyArgs) - ). + maplist(arg1(Head),Index,KeyArgs). %------------------------------------------------------------------------------- atomic_constants_code(C,Index,Constants,L,T) :- @@ -4060,11 +4029,12 @@ trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],T gensym(Prefix,RSymbol), append(DiffVars,[Result],RecCallVars), Body =.. [RSymbol|RecCallVars], - findall(CH-CT,member([CH|CT],Differences),CPairs), - once(pairup(CHs,CTs,CPairs)), + maplist(head_tail,Differences,CHs,CTs), trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail) ) ). + +head_tail([H|T],H,T). rec_cases([],[],[],_,[],[],[]). rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :- @@ -4365,14 +4335,15 @@ background_info(X) \ get_bg_info(Q) <=> Q=X. get_bg_info(Q) <=> Q = []. background_info(T,I), get_bg_info(A,Q) ==> - copy_term_nat(T,A) + copy_term_nat(T,T1), + subsumes_chk(T1,A) | copy_term_nat(T-I,A-X), get_bg_info_answer([X]). get_bg_info_answer(X), get_bg_info_answer(Y) <=> append(X,Y,XY), get_bg_info_answer(XY). -get_bg_info_answer(X), get_bg_info(A,Q) <=> Q=X. +get_bg_info_answer(X) # Id, get_bg_info(A,Q) <=> Q=X pragma passive(Id). get_bg_info(_,Q) <=> Q=[]. % no info found on this term %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -4545,7 +4516,6 @@ add_background_info2(X,Info) :- get_bg_info(X,XInfo), append(XInfo,XArgInfo,Info). - %% % when all earlier guards are added or skipped, we simplify the guard. % if it's different from the original one, we change the rule @@ -4801,22 +4771,6 @@ prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule) chr_warning(weird_program,'Heads will never match or guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]), set_all_passive(RuleNb). -/* -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% ALWAYS FAILING HEADS -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -rule(RuleNb,Rule) \ prev_guard_list(RuleNb,H,G,GuardList,M,[]) - <=> - chr_pp_flag(check_impossible_rules,on), - Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb), - append(M,GuardList,Info), - guard_entailment:entails_guard(Info,fail) - | - chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]), - set_all_passive(RuleNb). -*/ - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % HEAD SIMPLIFICATION %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -5120,32 +5074,43 @@ assert_constraint_type(Constraint,ArgTypes) :- %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Consistency checks of type aliases +type_alias(T1,T2) <=> + var(T1) + | + chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]). + +type_alias(T1,T2) <=> + var(T2) + | + chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]). + type_alias(T,T2) <=> - nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A), - copy_term((T,T2),(X,Y)),oneway_unification(Y,X) | - chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]). + functor(T,F,A), + functor(T2,F,A), + copy_term((T,T2),(X,Y)), subsumes(X,Y) + | + chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]). type_alias(T1,A1), type_alias(T2,A2) <=> - nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A), - \+ (T1\=T2) | - copy_term_nat(T1,T1_), - copy_term_nat(T2,T2_), - T1_ = T2_, - chr_error(type_error, - 'Ambiguous type aliases: you have defined \n\t`~w\'\n\t`~w\'\n\tresulting in two definitions for "~w".\n',[T1==A1,T2==A2,T1_]). + functor(T1,F,A), + functor(T2,F,A), + \+ (T1\=T2) + | + copy_term_nat(T1,T1_), + copy_term_nat(T2,T2_), + T1_ = T2_, + chr_error(type_error, + 'Ambiguous type aliases: you have defined \n\t`~w\'\n\t`~w\'\n\tresulting in two definitions for "~w".\n',[T1==A1,T2==A2,T1_]). type_alias(T,B) \ type_alias(X,T2) <=> - nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A), - copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) | + functor(T,F,A), + functor(T2,F,A), + copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)), + subsumes(T1,T3) + | % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]), type_alias(X2,D1). -oneway_unification(X,Y) :- - term_variables(X,XVars), - chr_runtime:lockv(XVars), - X=Y, - chr_runtime:unlockv(XVars). - %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Consistency checks of type definitions @@ -7850,7 +7815,7 @@ propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :- ) ; HistorySusp = Susp, - findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols), + maplist(extract_symbol,H2,ConstraintSymbols), sort([ID|RestIDs],HistoryIDs), history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps), Tuple =.. [t,RuleNb|HistorySusps] @@ -7906,6 +7871,9 @@ propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :- add_location(Clause,RuleNb,LocatedClause), L = [LocatedClause|T]. +extract_symbol(Head,F/A) :- + functor(Head,F,A). + novel_production_calls([],[],[],_,_,true). novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :- get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID), @@ -8033,7 +8001,8 @@ expand_data(Entry,NEntry,Cost) :- NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb), order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost). - % Assigns score to head based on known variables and heads to lookup +% Assigns score to head based on known variables and heads to lookup +% order_score(+head,+id,+knownvars,+heads,+rule_nb,-score). order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :- functor(Head,F,A), get_store_type(F/A,StoreType), @@ -8073,14 +8042,16 @@ order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleN order_score_indexes([],_,_,Score,NScore) :- Score > 0, NScore = 100. order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :- - multi_hash_key_args(I,Head,Args), - ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) -> + multi_hash_key_args(I,Head,Args), % TOM: not accurate enough? should look at vars? + ( maplist(memberchk_eq_flip(KnownVars),Args) /* forall(Arg,Args,memberchk_eq(Arg,KnownVars)) */ -> Score1 is Score + 1 ; Score1 = Score ), order_score_indexes(Is,Head,KnownVars,Score1,NScore). +memberchk_eq_flip(List,Element) :- memberchk_eq(Element,List). + order_score_vars(Vars,KnownVars,RestVars,Score) :- order_score_count_vars(Vars,KnownVars,RestVars,K-R-O), ( K-R-O == 0-0-0 -> @@ -8665,12 +8636,7 @@ existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,S % Filter out pairs already covered by given hash index. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% hash_index_filter(Pairs,Index,NPairs) :- - ( integer(Index) -> - NIndex = [Index] - ; - NIndex = Index - ), - hash_index_filter(Pairs,NIndex,1,NPairs). + hash_index_filter(Pairs,Index,1,NPairs). hash_index_filter([],_,_,[]). hash_index_filter([P|Ps],Index,N,NPairs) :- @@ -8819,7 +8785,7 @@ all_distinct_var_args(Term) :- copy_term_nat(Term,TermCopy), functor(Term,F,A), functor(Pattern,F,A), - Pattern =@= Term. + Pattern =@= TermCopy. get_indexed_arguments(C,IndexedArgs) :- C = F/A, @@ -9428,22 +9394,13 @@ unconditional_occurrence(C,O) :- PRule = pragma(ORule,_,_,_,_), copy_term_nat(ORule,Rule), Rule = rule(H1,H2,Guard,_), - % writeq(guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard)),nl, guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard), once(( H1 = [Head], H2 == [] ; H2 = [Head], H1 == [], \+ may_trigger(C) )), - functor(Head,F,A), - Head =.. [_|Args], - unconditional_occurrence_args(Args). - -unconditional_occurrence_args([]). -unconditional_occurrence_args([X|Xs]) :- - var(X), - X = x, - unconditional_occurrence_args(Xs). + all_distinct_var_args(Head). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -9642,11 +9599,7 @@ ht_prev_fields_int([H|T],Fields) :- ht_prev_fields_int(T,FT). ht_prev_field(Index,Field) :- - ( integer(Index) - -> atom_concat('multi_hash_prev-',Index,Field) - ; Index = [_|_] - -> concat_atom(['multi_hash_prev-'|Index],Field) - ). + concat_atom(['multi_hash_prev-'|Index],Field). get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :- suspension_term_base_fields(FA,Fields), @@ -10493,7 +10446,7 @@ dispatching_rule_term_cases(SFs,NC/N,Rules,RestRules) :- length(Terms,K), replicate(K,[],MorePatterns), Payload is N - 1, - maplist(dispatching_action,Functors,Actions), + maplist(wrap_in_functor(dispatching_action),Functors,Actions), dispatch_trie_index([Terms|MorePatterns],Payload,Actions,NC,Rules,RestRules). dispatching_action(Functor,PayloadArgs,Goal) :- -- 2.11.4.GIT