From 2270dc2cd581c3aedd3267aff00c7dec3cbcec59 Mon Sep 17 00:00:00 2001 From: Tom Schrijvers Date: Thu, 31 Jan 2008 21:16:38 +0100 Subject: [PATCH] code clean-up --- chr_compiler_utility.pl | 24 +------- chr_translate.chr | 139 ++++++++++++++++++++++++--------------------- chr_translate_bootstrap.pl | 26 ++++----- hprolog.pl | 11 +--- 4 files changed, 90 insertions(+), 110 deletions(-) diff --git a/chr_compiler_utility.pl b/chr_compiler_utility.pl index 9dba52a..28ea419 100644 --- a/chr_compiler_utility.pl +++ b/chr_compiler_utility.pl @@ -29,8 +29,7 @@ the GNU General Public License. */ :- module(chr_compiler_utility, - [ is_variant/2 - , time/2 + [ time/2 , replicate/3 , pair_all_with/3 , conj2list/2 @@ -63,27 +62,6 @@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -is_variant(A,B) :- - copy_term_nat(A,AC), - copy_term_nat(B,BC), - term_variables(AC,AVars), - term_variables(BC,BVars), - AC = BC, - is_variant1(AVars), - is_variant2(BVars). - -is_variant1([]). -is_variant1([X|Xs]) :- - var(X), - X = '$test', - is_variant1(Xs). - -is_variant2([]). -is_variant2([X|Xs]) :- - X == '$test', - is_variant2(Xs). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % time(Phase,Goal) :- % statistics(runtime,[T1|_]), % call(Goal), diff --git a/chr_translate.chr b/chr_translate.chr index d6db600..87327bb 100644 --- a/chr_translate.chr +++ b/chr_translate.chr @@ -60,7 +60,6 @@ %% %% AGGRESSIVE OPTIMISATION IDEAS %% -%% * success continuation optimization %% * analyze history usage to determine whether/when %% cheaper suspension is possible: %% don't use history when all partners are passive and self never triggers @@ -82,7 +81,6 @@ %% %% MORE TODO %% -%% * generate code to empty all constraint stores of a module (Bart Demoen) %% * map A \ B <=> true | true rules %% onto efficient code that empties the constraint stores of B %% in O(1) time for ground constraints where A and B do not share @@ -128,8 +126,6 @@ %% false -> smart backtracking %% only works for rules with at least 3 constraints in the head %% * (set semantics + functional dependency) declaration + resolution -%% * identify cases where prefixes of partner lookups for subsequent occurrences can be -%% merged %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- module(chr_translate, @@ -141,6 +137,7 @@ :- use_module(library(ordsets)). :- use_module(library(aggregate)). :- use_module(library(apply_macros)). +:- use_module(library(occurs)). %% SWI end :- use_module(hprolog). @@ -493,8 +490,21 @@ validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_mul <=> true % chr_pp_flag(experiment,on) | + ( Index = [IndexPos], + get_constraint_arg_type(C,IndexPos,chr_constants) + -> + Completeness = complete + ; + Completeness = incomplete + ), delete(STs,multi_hash([Index]),STs0), - actual_store_types(C,[ground_constants(Index,Keys,incomplete)|STs0]). + actual_store_types(C,[ground_constants(Index,Keys,Completeness)|STs0]). + +get_constraint_arg_type(C,Pos,Type) :- + get_constraint_type(C,Types), + nth1(IndexPos,Types,Type0), + unalias_type(Type0,Type). + validate_store_type_assumption(C) \ actual_store_types(C,STs) <=> % chr_pp_flag(experiment,on), @@ -508,21 +518,17 @@ validate_store_type_assumption(C) \ actual_store_types(C,STs) validate_store_type_assumption(C) \ actual_store_types(C,STs) <=> memberchk(multi_hash([[Index]]),STs), - get_constraint_type(C,Types), - nth1(Index,Types,Type), - unalias_type(Type,ActualType), - ActualType = chr_constants(Constants) + get_constraint_arg_type(C,Index,chr_constants(Constants)) | delete(STs,multi_hash([[Index]]),STs0), actual_store_types(C,[ground_constants([Index],Constants,complete)|STs0]). validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption <=> ( /* chr_pp_flag(experiment,on), */ forall(member(ST,STs), partial_store(ST)) -> - Stores0 = [global_ground|STs] + Stores = [global_ground|STs] ; - Stores0 = STs + Stores = STs ), - prune_stores(Stores0,Stores), store_type(C,multi_store(Stores)). validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption <=> @@ -540,18 +546,6 @@ validate_store_type_assumption(C) partial_store(ground_constants(_,_,incomplete)). partial_store(atomic_constants(_,_,incomplete)). - % heuristic to reduce the number of indexes -% prune_stores(Stores0,Stores) :- -% select(multi_hash([Indexes1]),Stores0,Stores1), -% Indexes1 = [_,_,_|_], -% member(multi_hash([Indexes2]),Stores1), -% Indexes2 = [_,_|_], -% subset(Indexes2,Indexes1), -% !, -% Stores = Stores1. - % default case -prune_stores(Stores,Stores). - %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% passive(R,ID) \ passive(R,ID) <=> true. @@ -3815,7 +3809,13 @@ multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :- ; ground(Key) -> actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key]) ; - actual_non_atomic_multi_hash_key(ConstraintSymbol,Index) + ( Index = [Pos], + get_constraint_arg_type(ConstraintSymbol,Pos,chr_constants) + -> + true + ; + actual_non_ground_multi_hash_key(ConstraintSymbol,Index) + ) ), delay_phase_end(validate_store_type_assumptions, multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)). @@ -3826,8 +3826,8 @@ multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :- :- chr_constraint actual_ground_multi_hash_keys/3. :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)). -:- chr_constraint actual_non_atomic_multi_hash_key/2. -:- chr_option(mode,actual_non_atomic_multi_hash_key(+,+)). +:- chr_constraint actual_non_ground_multi_hash_key/2. +:- chr_option(mode,actual_non_ground_multi_hash_key(+,+)). /* actual_atomic_multi_hash_keys(C,Index,Keys) @@ -3836,7 +3836,7 @@ actual_atomic_multi_hash_keys(C,Index,Keys) actual_ground_multi_hash_keys(C,Index,Keys) ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]). -actual_non_atomic_multi_hash_key(C,Index) +actual_non_ground_multi_hash_key(C,Index) ==> format('Keys: ~w - ~w : N/A\n', [C,Index]). */ actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2) @@ -3854,13 +3854,13 @@ actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,In sort(Keys0,Keys), actual_ground_multi_hash_keys(C,Index,Keys). -actual_non_atomic_multi_hash_key(C,Index) \ actual_non_atomic_multi_hash_key(C,Index) +actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index) <=> true. -actual_non_atomic_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_) +actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_) <=> true. -actual_non_atomic_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_) +actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_) <=> true. %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name) @@ -4065,25 +4065,36 @@ rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cas rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults) ). -% common_pattern(+terms,-term,-vars,-differences) +%% common_pattern(+terms,-term,-vars,-differences) is det. common_pattern(Ts,T,Vars,Differences) :- fold1(gct,Ts,T), term_variables(T,Vars), findall(Vars,member(T,Ts),Differences). gct(T1,T2,T) :- - ( nonvar(T1), nonvar(T2), - functor(T1,F1,A1), - functor(T2,F2,A2), - F1 == F2, A1 == A2 -> + gct_(T1,T2,T,[],_). + +gct_(T1,T2,T,Dict0,Dict) :- + ( nonvar(T1), + nonvar(T2), + functor(T1,F1,A1), + functor(T2,F2,A2), + F1 == F2, + A1 == A2 -> functor(T,F1,A1), T1 =.. [_|Args1], T2 =.. [_|Args2], T =.. [_|Args], - maplist(gct,Args1,Args2,Args) + maplist_dcg(gct_,Args1,Args2,Args,Dict0,Dict) ; /* T is a variable */ - true + ( lookup_eq(Dict0,T1+T2,T) -> + /* we already have a variable for this difference */ + Dict = Dict0 + ; + /* T is a fresh variable */ + Dict = [(T1+T2)-T|Dict0] + ) ). @@ -4094,6 +4105,14 @@ fold([],_,Acc,Acc). fold([X|Xs],P,Acc,Res) :- call(P,X,Acc,NAcc), fold(Xs,P,NAcc,Res). + +maplist_dcg(P,L1,L2,L) --> + maplist_dcg_(L1,L2,L,P). + +maplist_dcg_([],[],[],_) --> []. +maplist_dcg_([X|Xs],[Y|Ys],[Z|Zs],P) --> + call(P,X,Y,Z), + maplist_dcg_(Xs,Ys,Zs,P). %------------------------------------------------------------------------------- global_list_store_name(F/A,Name) :- get_target_module(Mod), @@ -5280,7 +5299,10 @@ type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :- ; dense_int ; chr_identifier ; chr_identifier(any) - ; chr_constants(list(any)). + ; /* all possible values are given */ + chr_constants(list(any)) + ; /* all possible values appear in rule heads */ + chr_constants. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% atomic_builtin_type(any,_Arg,true). @@ -5290,6 +5312,7 @@ atomic_builtin_type(number,Arg,number(Arg)). atomic_builtin_type(float,Arg,float(Arg)). atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)). atomic_builtin_type(chr_identifier,_Arg,true). +atomic_builtin_type(chr_constants,_Arg,true). compound_builtin_type(chr_identifier(_),_Arg,true,true). compound_builtin_type(chr_constants(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)), @@ -5341,7 +5364,7 @@ type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :- constraint_type(Constraint,ArgTypes), static_type_check ==> forall( - ( member(ArgType,ArgTypes), forsubterm(ArgType,Type) ), + ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ), ( get_type_definition(Type,_) -> true ; @@ -5349,17 +5372,6 @@ constraint_type(Constraint,ArgTypes), static_type_check ) ). - -forsubterm(Term,SubTerm) :- - ( - SubTerm = Term - ; - Term =.. [_|Args], - member(Arg,Args), - forsubterm(Arg,SubTerm) - ). - - % 2. Check the rules :- chr_type type_error_src ---> head(any) ; body(any). @@ -6983,7 +6995,7 @@ passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :- get_constraint_mode(F/A,ArgModes), ( Vars == [] -> Goal = GlobalGoal - ; member(CommonVar,CommonVars), nth(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar -> + ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar -> translate([CommonVar],VarDict,[Var]), gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps), Goal = AttrGoal @@ -8611,10 +8623,10 @@ assume_constraint_stores([C|Cs]) :- get_indexed_arguments(C,AllIndexedArgs), get_constraint_mode(C,Modes), % findall(Index,(member(Index,AllIndexedArgs), - % nth(Index,Modes,+)),IndexedArgs), + % nth1(Index,Modes,+)),IndexedArgs), % length(IndexedArgs,NbIndexedArgs), aggregate_all(bag(Index)-count, - (member(Index,AllIndexedArgs),nth(Index,Modes,+)), + (member(Index,AllIndexedArgs),nth1(Index,Modes,+)), IndexedArgs-NbIndexedArgs), % Construct Index Combinations ( NbIndexedArgs > 10 -> @@ -8675,7 +8687,7 @@ assume_constraint_stores([C|Cs]) :- partition_indexes([],_,[],[],[],[]). partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :- ( Index = [I], - nth(I,Types,Type), + nth1(I,Types,Type), unalias_type(Type,UnAliasedType), UnAliasedType == chr_identifier -> IdentifierIndexes = [I|RIdentifierIndexes], @@ -8683,7 +8695,7 @@ partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierInd HashIndexes = RHashIndexes, CompoundIdentifierIndexes = RCompoundIdentifierIndexes ; Index = [I], - nth(I,Types,Type), + nth1(I,Types,Type), unalias_type(Type,UnAliasedType), nonvar(UnAliasedType), UnAliasedType = chr_identifier(IndexType) -> @@ -8692,7 +8704,7 @@ partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierInd IntHashIndexes = RIntHashIndexes, HashIndexes = RHashIndexes ; Index = [I], - nth(I,Types,Type), + nth1(I,Types,Type), unalias_type(Type,UnAliasedType), UnAliasedType == dense_int -> IntHashIndexes = [Index|RIntHashIndexes], @@ -8700,7 +8712,7 @@ partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierInd IdentifierIndexes = RIdentifierIndexes, CompoundIdentifierIndexes = RCompoundIdentifierIndexes ; member(I,Index), - nth(I,Types,Type), + nth1(I,Types,Type), unalias_type(Type,UnAliasedType), nonvar(UnAliasedType), UnAliasedType = chr_identifier(_) -> @@ -9562,7 +9574,7 @@ ht_prev_field(Index,Field) :- get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :- suspension_term_base_fields(FA,Fields), - nth(Index,Fields,FieldName), !, + nth1(Index,Fields,FieldName), !, arg(Index,StaticSuspension,Field). get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !, suspension_term_base(FA,Base), @@ -9574,7 +9586,7 @@ get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :- get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :- suspension_term_base_fields(FA,Fields), - nth(Index,Fields,FieldName), !, + nth1(Index,Fields,FieldName), !, Goal = arg(Index,DynamicSuspension,Field). get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !, static_suspension_term(FA,StaticSuspension), @@ -9590,7 +9602,7 @@ get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :- suspension_term_base_fields(FA,Fields), - nth(Index,Fields,FieldName), !, + nth1(Index,Fields,FieldName), !, Goal = setarg(Index,DynamicSuspension,Field). set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :- chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]). @@ -10046,9 +10058,8 @@ get_success_continuation_code_id(C,O,NextId) :- dump_code(Clauses) :- ( chr_pp_flag(dump,on), - member(D,Clauses), - copy_term_nat(D,Dprime), - portray_clause(Dprime), + member(Clause,Clauses), + portray_clause(Clause), fail ; true diff --git a/chr_translate_bootstrap.pl b/chr_translate_bootstrap.pl index bfcdef6..7f08b95 100644 --- a/chr_translate_bootstrap.pl +++ b/chr_translate_bootstrap.pl @@ -536,13 +536,13 @@ generate_attach_a_constraint_t_p(Total,Position,CFct / CAty ,Mod,Clause) :- RecursiveCall =.. [Fct,Vars,Susp], or_pattern(Position,Pattern), make_attr(Total,Mask,SuspsList,Attr), - nth(Position,SuspsList,Susps), + nth1(Position,SuspsList,Susps), substitute_eq(Susps,SuspsList,[Susp|Susps],SuspsList1), make_attr(Total,Mask,SuspsList1,NewAttr1), substitute_eq(Susps,SuspsList,[Susp],SuspsList2), make_attr(Total,NewMask,SuspsList2,NewAttr2), copy_term_nat(SuspsList,SuspsList3), - nth(Position,SuspsList3,[Susp]), + nth1(Position,SuspsList3,[Susp]), chr_delete(SuspsList3,[Susp],RestSuspsList), set_elems(RestSuspsList,[]), make_attr(Total,Pattern,SuspsList3,NewAttr3), @@ -618,7 +618,7 @@ generate_detach_a_constraint_t_p(Total,Position,CFct / CAty ,Mod,Clause) :- or_pattern(Position,Pattern), and_pattern(Position,DelPattern), make_attr(Total,Mask,SuspsList,Attr), - nth(Position,SuspsList,Susps), + nth1(Position,SuspsList,Susps), substitute_eq(Susps,SuspsList,[],SuspsList1), make_attr(Total,NewMask,SuspsList1,Attr1), substitute_eq(Susps,SuspsList,NewSusps,SuspsList2), @@ -1420,9 +1420,9 @@ rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,Act ( N == 1 -> VarSusps = Attr ; - nth(Pos,Constraints,Fct/Aty), !, + nth1(Pos,Constraints,Fct/Aty), !, make_attr(N,_Mask,SuspsList,Attr), - nth(Pos,SuspsList,VarSusps) + nth1(Pos,SuspsList,VarSusps) ), different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals), create_get_mutable_ref(active,State,GetMutable), @@ -1461,7 +1461,7 @@ check_unique_keys([V|Vs],Dict) :- % Generates tests to ensure the found constraint differs from previously found constraints different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :- - ( bagof(DiffSuspGoal, Pos ^ ( nth(Pos,Heads,PreHead), \+ Head \= PreHead, nth(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) -> + ( bagof(DiffSuspGoal, Pos ^ ( nth1(Pos,Heads,PreHead), \+ Head \= PreHead, nth1(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) -> list2conj(DiffSuspGoalList,DiffSuspGoals) ; DiffSuspGoals = true @@ -1469,7 +1469,7 @@ different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :- passive_head_via(Head,PrevHeads,AttrDict,Constraints,Mod,VarDict,Goal,Attr,NewAttrDict) :- functor(Head,F,A), - nth(Pos,Constraints,F/A),!, + nth1(Pos,Constraints,F/A),!, common_variables(Head,PrevHeads,CommonVars), translate(CommonVars,VarDict,Vars), or_pattern(Pos,Bit), @@ -1700,9 +1700,9 @@ simpagation_head2_prelude(Head,Head1,Rest,F/A,_I,N,Constraints,Mod,Id1,L,T) :- AllSusps = Attr ; functor(Head1,F1,A1), - nth(Pos,Constraints,F1/A1), !, + nth1(Pos,Constraints,F1/A1), !, make_attr(N,_,SuspsList,Attr), - nth(Pos,SuspsList,AllSusps) + nth1(Pos,SuspsList,AllSusps) ), ( Id1 == [0] -> % create suspension @@ -1942,8 +1942,8 @@ propagation_prelude(Head,[First|Rest],Rule,F/A,N,Constraints,Mod,Id,L,T) :- ; functor(First,FirstFct,FirstAty), make_attr(N,_Mask,SuspsList,Attr), - nth(Pos,Constraints,FirstFct/FirstAty), !, - nth(Pos,SuspsList,Susps) + nth1(Pos,Constraints,FirstFct/FirstAty), !, + nth1(Pos,SuspsList,Susps) ), ( Id == [0] -> @@ -2121,9 +2121,9 @@ propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,N,C ( N == 1 -> NextSusps = Attr ; - nth(Position,Constraints,NextF/NextA), !, + nth1(Position,Constraints,NextF/NextA), !, make_attr(N,_Mask,SuspsList,Attr), - nth(Position,SuspsList,NextSusps) + nth1(Position,SuspsList,NextSusps) ), inc_id(Id,NestedId), ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], diff --git a/hprolog.pl b/hprolog.pl index 99209f8..8116ee5 100644 --- a/hprolog.pl +++ b/hprolog.pl @@ -1,6 +1,5 @@ :- module(hprolog, - [ nth/3, % ?Index, ?List, ?Element - substitute_eq/4, % +OldVal, +OldList, +NewVal, -NewList + [ substitute_eq/4, % +OldVal, +OldList, +NewVal, -NewList memberchk_eq/2, % +Val, +List intersect_eq/3, % +List1, +List2, -Intersection list_difference_eq/3, % +List, -Subtract, -Rest @@ -51,14 +50,6 @@ make_update_store_goal(Name,Value,Goal) :- Goal = b_setval(Name,Value). * MORE LIST OPERATIONS * *******************************/ -% nth(?Index, ?List, ?Element) -% -% Same as nth1/3 - -nth(Index, List, Element) :- - nth1(Index, List, Element). - - % substitute_eq(+OldVal, +OldList, +NewVal, -NewList) % % Substitute OldVal by NewVal in OldList and unify the result -- 2.11.4.GIT