/******************************************************************* * * C1 Common Lisp compiler/interpretor, written in Prolog * * (xxxxx.pl) * * * Douglas'' Notes: * * (c) Douglas Miles, 2017 * * The program is a *HUGE* common-lisp compiler/interpreter. It is written for YAP/SWI-Prolog . * *******************************************************************/ :- module(mizepro, []). :- set_module(class(library)). :- include('./header'). debug_optimize(Msg):- dmsg(Msg). allowed_level(X):- wam_cl_option(safety,V),V\==1,!,Lvl is 4-V, X =< Lvl. allowed_level(X):- wam_cl_option(speed,V), X =< V. /* 0 = dont trust any 1 = (probably) very safe ones 2 = under review 3 = experimental ones */ body_cleanup(Ctx,CodeIn,CodeOut):- quietly(body_cleanup_full(Ctx,CodeIn,CodeOut)). body_cleanup_keep_debug_vars(Ctx,CodeIn,CodeOut):- quietly(body_cleanup_full(Ctx,CodeIn,CodeOut)),!. body_cleanup_no_optimize(Ctx,CodeSt,CodeIn):-!, quietly(always(( %show_ctx_info(Ctx), sanitize_true(Ctx,CodeSt,CodeIn), %del_attrs_of(CodeIn,freeze), ! % inline_body([],Ctx,',',CodeIn,Code5a) ))),!. body_cleanup_keep_debug_vars_fuller(Ctx,CodeSt,Code5a):-!, quietly(always(( %show_ctx_info(Ctx), sanitize_true(Ctx,CodeSt,CodeIn), del_attrs_of(CodeIn,freeze), (inline_body([],Ctx,',',CodeIn,Code5a)), del_attrs_of(Code5a,dif) ))),!. %body_cleanup_full(Ctx,CodeSt,CodeOutNow):- body_cleanup_keep_debug_vars_fuller(Ctx,CodeSt,CodeOutNow),!. %body_cleanup_full(_Ctx,I,I):-!. body_cleanup_full(_Ctx,CodeSt,CodeOutNow):- var(CodeSt),!,CodeOutNow=CodeSt. %body_cleanup_full(Ctx,:- CodeSt,:- CodeOutNow):-!,body_cleanup_full(Ctx,CodeSt,CodeOutNow). body_cleanup_full(Ctx,CodeSt,CodeOutNow):- quietly(always(( %show_ctx_info(Ctx), %properly_protect(Ctx,CodeSt,_), sanitize_true(Ctx,CodeSt,CodeIn), del_attrs_of(CodeIn,freeze), inline_operation([],Ctx,',',CodeIn,Code0), body_cleanup_keep_debug_vars1(Ctx,Code0,Code2), body_cleanup_keep_debug_vars1(Ctx,Code2,Code3), env_mize(Ctx,',',Code3,Code4), %inline_operation([],Ctx,',',Code4,Code5ab), inline_body([],Ctx,',',Code4,Code5a), fast_get_sets(Ctx,',',Code5a,Code5), % body_cleanup_keep_debug_vars1(Ctx,Code5,CodeOut), add_type_checks_maybe(Ctx,CodeOut,CodeOutNow), del_attrs_of(CodeOutNow,preserved_var), del_attrs_of(CodeOutNow,dif)))). add_type_checks_maybe(_,IO,IO). body_cleanup_keep_debug_vars1(Ctx,I,O):- !, body_cleanup_no_optimize(Ctx,I,O),!. body_cleanup_keep_debug_vars1(Ctx,Code0,CodeOutOut):- must_det_l((oper_mize(Code0,Ctx,',',Code0,Code1), mize_body(Ctx,',',Code1,CodeOut), sanitize_true(Ctx,CodeOut,CodeOutOut1), fast_get_sets(Ctx,'',CodeOutOut1,CodeOutOut))). fast_get_sets(_Ctx,_,Code5,Code5):- \+ compound(Code5),!. fast_get_sets(Ctx,F,(C1,C2,C4),C5):- conjoinment(Ctx,C1,C2,C3),!,fast_get_sets(Ctx,F,(C3,C4),C5). fast_get_sets(Ctx,F,(C1,C2),Joined):- conjoinment(Ctx,C1,C2,C3),C3\==(C1,C2),!,fast_get_sets(Ctx,F,C3,Joined). fast_get_sets(Ctx,_F,C1,C2):- compound_name_arguments(C1,F,C1O),must_maplist(fast_get_sets(Ctx,F),C1O,C2O),C2=..[F|C2O]. fast_get_sets(_Ctx,_,Code5,Code5). non_compound_code(NC):- notrace(non_compound_code1(NC)),!. non_compound_code1(NC):- \+ callable(NC),!. non_compound_code1(NC):- \+ compound(NC). %non_compound_code1(NC):- is_list(NC). non_compound_code1(NC):- is_self_evaluating_object(NC),!. non_compound_code1(NC):- is_dict(NC). skip_optimize(NC):- non_compound_code(NC),!. skip_optimize(NC):-notrace(skip_optimize0(NC)). skip_optimize0([_|_]):-!. skip_optimize0(_:P):-!,skip_optimize(P). skip_optimize0(P):- functor(P,F,_),atom_concat_or_rtrace('$',_,F). skip_optimize0(retractall(_)). skip_optimize0(retract(_)). skip_optimize0(erase(_)). always_true(G):- \+ ground(G),fail. always_true(true). always_true(t\==[]). always_true([]\==t). functor_arg_is_body(F,_):- atom_concat_or_rtrace(assert,_,F). functor_arg_is_body(((:-)),1). %oper_mize(_Whole,_Ctx,_,Code,Code):-!. oper_mize(_Whole,_Ctx,_,Code,Out):- skip_optimize(Code),Out=Code. %oper_mize(_Whole,Ctx,F,(:-C1),(:-C2)):-!, oper_mize(C1,Ctx,F,C1,C2). oper_mize(_Whole,_Ctx,_F,(C1,C2),U_x_Param=CondResult):- %wam_cl_option(elim_vars,true), C1= (U_x_Param=S1) , C2= (CondResult=S2), var(S1), S1==S2,!. oper_mize(_Whole,Ctx,F,(C1,C2),Joined):-!, oper_mize(C1,Ctx,F,C1,C1O), oper_mize(C2,Ctx,F,C2,C2O), conjoin_0(Ctx,C1O,C2O,Joined). oper_mize(_Whole,Ctx,F,[C1|C2],Joined):-!,oper_mize(C1,Ctx,F,C1,C1O),oper_mize(C2,Ctx,F,C2,C2O),([C1O|C2O] = Joined). oper_mize(W,_Ctx,_,Var1 = Var2, true):- wam_cl_option(elim_vars,true), var(Var1),var(Var2), occurrences_of_var(Var1,W,N)-> N==2. %oper_mize(_Whole,Ctx,_,C1=C2, true):- var(C1),var(C2),maybe_keep,C1=C2,!. oper_mize(_Whole,Ctx,FF,PAB,PABO):- PAB=..[F,C1|Rest],functor(PAB,F,A),functor_arg_is_body(F,A), oper_mize(C1,Ctx,FF,C1,C2),PABO=..[F,C2|Rest]. oper_mize(_Whole,Ctx,FF,(H:-C1),(H:-C2)):- nonvar(H),!,functor(H,F,A), body_mize([F/A],(H:-C1),Ctx,FF,C1,C2). oper_mize(W,Ctx,F,always(C1),always(C2)):-!,oper_mize(W,Ctx,F,(C1),(C2)). oper_mize(W,Ctx,F,call(C1),call(C2)):-!,oper_mize(W,Ctx,F,(C1),(C2)). oper_mize(W,Ctx,F,C1,C2):- body_mize([],W,Ctx,F,C1,C2). oper_mize(_Skip,W,Ctx,F,C2,C2O):- oper_mize(W,Ctx,F,C2,C2O). body_mize(_Skip,_Whole,_Ctx,_,Code,Out):- skip_optimize(Code),Out=Code. body_mize(Skip,_Whole,_Ctx,_,Code,Out):- functor(Code,F,N),member(F/N,Skip),Out=Code. %body_mize(_Skip,W,_Ctx,_,Var = Ground, true):- var(Var),ground(Ground), trace, occurrences_of_var(Var,W,N)-> N==2. body_mize(_Skip,_Whole,_Ctx,_,C1,C1):-!. body_mize(Skip,W,Ctx,F,(C1,C2),Joined):-!, body_mize(Skip,W,Ctx,F,C1,C1O), body_mize(Skip,W,Ctx,F,C2,C2O),conjoin_0(Ctx,C1O,C2O,Joined). %body_mize(Skip,_Whole,_Ctx,_,C1,Out):- maybe_optimize(C1), get_optimized(C1,Out). body_mize(__Skip,_Whole,_Ctx,_,C1,C1):- non_compound_code(C1),!. body_mize(Skip,W,Ctx,F,call(C1),call(C2)):-!, oper_mize(Skip,W,Ctx,F,C1,C2). body_mize(Skip,W,Ctx,F,(C1,C2),Joined):-!, oper_mize(Skip,W,Ctx,F,C1,C1O), oper_mize(Skip,W,Ctx,F,C2,C2O), conjoin_0(Ctx,C1O,C2O,Joined). body_mize(Skip,W,Ctx,F,(C1;C2),(C1O;C2O)):-!, oper_mize(Skip,W,Ctx,F,C1,C1O), oper_mize(Skip,W,Ctx,F,C2,C2O). /*body_mize(Skip,W,Ctx,F,(P1->C1;C2),(P1O->C1O;C2O)):-!, oper_mize(Skip,W,Ctx,F,P1,P1O), oper_mize(Skip,P1->C1,Ctx,F,C1,C1O), oper_mize(Skip,P1->C2,Ctx,F,C2,C2O). */ body_mize(Skip,W,Ctx,_F,C1,C2):- compound_name_arguments(C1,F,C1ARGS), must_maplist(body_mize(Skip,W,Ctx,F),C1ARGS,C2O), C2=..[F|C2O]. body_mize(_Skip,_Whole,_Ctx,_,C1,C1):-!. maybe_optimize(_). properly_protect(_, C1,C2):- non_compound_code(C1),!,C2=C1. properly_protect(_, X=Y,X=Y):-!. properly_protect(_Ctx,P,P):- predicate_property(P,foreign),stay_all_different(P),!. %properly_protect(_Ctx,P,P):- \+ predicate_property(P,imported_from(system)),!,stay_all_different(P). properly_protect(Ctx,(C1,C2),Joined):-!,properly_protect(Ctx,C1,C1O),properly_protect(Ctx,C2,C2O),conjoin_0(Ctx,C1O,C2O,Joined),!. properly_protect(_Ctx,(C1:-C2),(C1:-C2)):-stay_all_different(C1),!. %properly_protect(Ctx,(C1 -> C2 ; CodeC),(C1O -> C2O ; CodeCCO)):-!,properly_protect(Ctx,C1,C1O),properly_protect(Ctx,C2,C2O),properly_protect(Ctx,CodeC,CodeCCO). properly_protect(Ctx,C1,C2):- compound_name_arguments(C1,F,C1O),must_maplist(properly_protect(Ctx),C1O,C2O),C2=..[F|C2O]. del_attr_rev2(Name,Var):- del_attr(Var,Name). del_attrs_of(CodeIn,Name):- term_variables(CodeIn,AttVars),maplist(del_attr_rev2(Name),AttVars). sanitize_true(_, C1,C2):- \+ compound(C1),!,C2=C1. sanitize_true(_, C1,C2):- non_compound_code(C1),!,C2=C1. %sanitize_true(_,f_sys_pf_set_slot_value(A,B,C,D),set_slot(A,B,C)):-C=D. sanitize_true(_,f_slot_value(A,B,C),get_opv(A,B,C)). sanitize_true(Ctx,(C1,C2),Joined):-!,sanitize_true(Ctx,C1,C1O),sanitize_true(Ctx,C2,C2O),conjoin_0(Ctx,C1O,C2O,Joined). sanitize_true(Ctx,(C2 ; CodeC),( C2O ; CodeCCO)):-!,sanitize_true(Ctx,C2,C2O),sanitize_true(Ctx,CodeC,CodeCCO). sanitize_true(Ctx,(C2 -> CodeC),( C2O -> CodeCCO)):-!,sanitize_true(Ctx,C2,C2O),sanitize_true(Ctx,CodeC,CodeCCO). sanitize_true(Ctx,(C2 :- CodeC),( C2 :- CodeCCO)):-!,sanitize_true(Ctx,CodeC,CodeCCO). sanitize_true(Ctx,( :- CodeC),( :- CodeCCO)):-!,sanitize_true(Ctx,CodeC,CodeCCO). sanitize_true(_Ctx,C1,C1):-!. :- '$hide'(sanitize_true/3). %sanitize_true(Ctx,C1,C2):- compound_name_arguments(C1,F,C1O),must_maplist(sanitize_true(Ctx),C1O,C2O),C2=..[F|C2O]. keeper(C1):- var(C1),!. keeper(!). discard(C2):- C2==true. conjoin_1(Ctx,C1,C2,C3):- discard(C2),!,visit_lit(Ctx,C1,C3). conjoin_1(Ctx,C1,C2,C3):- discard(C1),!,visit_lit(Ctx,C2,C3). conjoin_1(_,C1,C2,C2):- C1==C2,C2==reset_mv,!. conjoin_1(_,clean_escape(_),_,true):- !. %conjoin_1(Ctx,C1,C2,C3):- conjoinment(Ctx,C1,C2,C3),!. conjoin_0(Ctx,C1,C2,(C1,C3)):- keeper(C1),!,visit_lit(Ctx,C2,C3). conjoin_0(Ctx,C1,C2,(C3,C2)):- keeper(C2),!,visit_lit(Ctx,C1,C3). %conjoin_0(Ctx,C1,clean_escape(_),C1):- trace,!. conjoin_0(_,(clean_escape(_),_),_,true):- !. conjoin_0(Ctx,(C1,clean_escape(_)),_,C3):- visit_lit(Ctx,C1,C3). conjoin_0(Ctx,C1,(clean_escape(_),_),C3):- visit_lit(Ctx,C1,C3). conjoin_0(Ctx,C1,C2,C4):- conjoin_1(Ctx,C1,C2,C3),!,visit_lit(Ctx,C3,C4). conjoin_0(Ctx,C1,(C2,C2a),C3):-conjoin_1(Ctx,C1,C2,C12),!,conjoin_0(Ctx,C12,C2a,C3). conjoin_0(Ctx,(C1,C1O),C2,OUT):-!,conjoin_0(Ctx,C1O,C2,AAB),conjoin_0(Ctx,C1,AAB,OUT). conjoin_0(Ctx,C1,C2,(C11,C21)):- !,visit_lit(Ctx,C1,C11),!,visit_lit(Ctx,C2,C21). visit_lit(_,C1,C1):-!. visit_lit(_,C1,C1):-keeper(C1),!. visit_lit(Ctx,C1,C2):-sanitize_true(Ctx,C1,C2). mize_body(_Ctx,_,C1,C1):- non_compound_code(C1),!. mize_body(Ctx,F, :-(C1), :-(C1O)):-!,mize_body(Ctx,F,C1,C1O). mize_body(Ctx,F,(C1,C2),CodeJoined):-!,mize_body(Ctx,F,C1,C1O),mize_body(Ctx,F,C2,C2O),conjoin_0(Ctx,C1O,C2O,CodeJoined). %mize_body(Ctx,_,(C1 -> C2 ; _),C2O):- mize_body(Ctx,->,C1,C1O),always_true(C1O),mize_body(Ctx,';',C2,C2O),!. mize_body(_Ctx,_,(C1 -> C2 ; _),C2):- fail, wam_cl_option(safe(elim_always_trues),true), always_true(C1),!. mize_body(Ctx,_,(C1 -> C2 ; CodeC),(C1O -> C2O ; CodeCCO)):-!,mize_body(Ctx,'->',C1,C1O),mize_body(Ctx,';',C2,C2O),mize_body(Ctx,';',CodeC,CodeCCO). mize_body(Ctx,_,(C2 ; CodeC),( C2O ; CodeCCO)):-!,mize_body(Ctx,';',C2,C2O),mize_body(Ctx,';',CodeC,CodeCCO). mize_body(Ctx,F,C1,CodeC):- mize_body1(Ctx,F,C1,C2),mize_body2(Ctx,F,C2,CodeC),!. mize_body(Ctx,_,catch(C1,E, C2),catch(C1O,E, C2O)):- !, mize_body(Ctx,->,C1,C1O),mize_body(Ctx,';',C2,C2O). %mize_body(Ctx,_F,C1,C2):- compound_name_arguments(C1,F,C1O),must_maplist(mize_body(Ctx,F),C1O,C2O),C2=..[F|C2O]. %mize_body(_Ctx,_,C1,C1):-!. structure_applies(A,B):- copy_term_nat(A,CA),numbervars(CA,0,_), \+ (CA \= B), A=B. structure_variant(A,B):- copy_term_nat(A,CA),copy_term_nat(B,CB),numbervars(CA,0,_),numbervars(CB,0,_), \+ (CA \= CB), A=B. conjoinment0(C1,C2,C2):- C1==C2,C2==reset_mv,!. conjoinment0(A,B,_):- ( ( \+ compound(A)) ; \+ compound(B)), !,fail. conjoinment0(get_var(ReplEnv1, Var1, Value1),get_var(ReplEnv2, Var2, Value2), get_var(ReplEnv1, Var1, Value1)):- Var1==Var2,ReplEnv2==ReplEnv1,Value1=Value2. conjoinment0(get_var(ReplEnv1, Var1, Value1),get_var(ReplEnv2, Var2, Value2), (get_var(ReplEnv2, Var2, Value2),get_var(ReplEnv1, Var1, Value1))):- Var1 @> Var2,!. %fail, %Value1=Value2,!. %get_var(LETENV318, u_l, Nreverse_Param), %U_l=[CAR496|Nreverse_Param], %set_var(LETENV318, setq, u_l, U_l) conjoinment1(A,B,_):- ( ( \+ compound(A)) ; \+ compound(B)), !,fail. conjoinment1(C1,(AEQB,C2),(C3,AEQB)):- move_down(AEQB),conjoinment0(C1,C2,C3). conjoinment1(C1,C2,C3):- conjoinment0(C1,C2,C3). conjoinment(_Ctx,C1,C2,C3):-conjoinment1(C1,C2,C3). move_down(AEB):-var(AEB),!,fail. move_down(A=B):- nop(var(A)), is_list(B). ifthenelse(P):-structure_applies(P,( _ -> _ ; _ )). structure_applies_here(In,In2,Body):- var(In2),In=In2,!,call(Body). structure_applies_here(In,In2,Body):- structure_applies(In,In2),call(Body). mize_body1(_Ctx,_F,In,Out):-skip_optimize(In),!,In=Out. mize_body1(Ctx,F,In,Out):- clause(mize_body_1e(Ctx,F,In2,Out2),Body), structure_applies_here(In,In2,Body),!, (In \== Out2 -> mize_body1(Ctx,F,Out2,Out);Out=In),!. mize_body1(_Ctx,_F,InOut,InOut). idiom_replace(set_var(E, OP, N, V),set_var(E, N, V)):- var(V), atom(N),atom(OP),memberchk(OP,[psetq,setf,setq]). idiom_replace(set_place(E, OP, N, V),set_var(E, N, V)):- var(V), atom(N),atom(OP),memberchk(OP,[psetq,setf,setq]). idiom_replace(set_var(E, OP, [PLACE, N], V),set_place(E, OP, [PLACE, N], V)):- var(V), atom(N),atom(OP),memberchk(OP,[setf]). no_block_exists(G):- \+ has_block_exists(G). has_block_exists(G):- sub_term(E,G),sub_block_exit(E). sub_block_exit(E):- E==fail,!. sub_block_exit(E):- \+ compound(E),!,fail. sub_block_exit(C):-functor(C,F,A),sub_block_exit_f_a(F,A). sub_block_exit_f_a(Addr,_):- atom(Addr), atom_contains(Addr,'addr_'). sub_block_exit_f_a(throw,1). sub_block_exit_f_a(catch,3). mize_body_1e(_Ctx,_,C1,C1):- non_compound_code(C1),!. mize_body_1e(_Ctx,_,C1,C2):- idiom_replace(C1,C2). mize_body_1e(_Ctx,_F,(A=B),true):- A==B,allowed_level(1),!. mize_body_1e(_Ctx,_F,(A==B),true):- A==B,allowed_level(1),!. mize_body_1e(_Ctx,_,f_list(G, R),R=G):- allowed_level(1),!. mize_body_1e(_Ctx,_,C1,L=[R]):- structure_applies(C1 , (L=[R, []])). % wam_cl_option(elim_vars,true). mize_body_1e(Ctx,F,(C1,C2,C4),C5):- conjoinment(Ctx,C1,C2,C3),!,mize_body_1e(Ctx,F,(C3,C4),C5). mize_body_1e(Ctx,F,(C1,C2),Joined):- conjoinment(Ctx,C1,C2,C3),!,mize_body_1e(Ctx,F,C3,Joined). mize_body_1e(Ctx,F,(C1,C2),CodeJoined):-!,mize_body1(Ctx,F,C1,C1O),mize_body1(Ctx,F,C2,C2O),conjoin_0(Ctx,C1O,C2O,CodeJoined). mize_body_1e(Ctx,_,get_var(Env, Sym, Sym_Get),OUT):- wam_cl_option(var_rw_counts,true), nop(OUT = 'O'(get_var(Env, Sym, Sym_Get),true)), OUT = true, % wam_cl_option(safe(elim_symbolvalues_vars),true), get_var_tracker(Ctx,Sym,Dict), (Dict.w=1 ; ( Dict.p=1,Dict.w=0)), % ((Dict.p==1-> )) % Dict.u<2, %Dict.r>=0, debug_optimize(mize_body_1e:- Dict), allowed_level(2), % rw_add(Ctx,Sym,u), Dict.vars=[Was|_], Was\==Sym_Get, (call(Was=Sym_Get)),!. %mize_body1(Ctx,_F,C1,C2):- compound_name_arguments(C1,F,C1O),must_maplist(mize_body1(Ctx,F),C1O,C2O),C2=..[F|C2O]. %mize_body1(Ctx,F,C1,C2):- is_list(C1),must_maplist(mize_body1(Ctx,F),C1,C2). mize_body_1e(_Ctx,_,append([], R, W),R= W):- ignore(R= W),allowed_level(1),!. mize_body_1e(_Ctx,_,Env=[],true):- Env=[],!,allowed_level(2),!. mize_body_1e(_Ctx,_,C1,C1):-!. 'O'(Old,New):- New,nop(Old). % 'O'(Old,New):- nop(New),Old. mize_body2(Ctx,F,In,Out):- clause(mize_body_2e(Ctx,F,In2,Out2),Body), structure_applies_here(In,In2,Body),!, (In\==Out2 -> mize_body2(Ctx,F,Out2,Out);Out=In),!. mize_body2(_Ctx,_F,InOut,InOut). mize_body_2e(_Ctx,_,C1,C1):- non_compound_code(C1),!. mize_body_2e(_,_,In,ITE):- structure_applies(In,(ITE,R=V)), var(R),var(V),ifthenelse(ITE),R=V,allowed_level(1). %mize_body_2e(_Ctx,_,(S1=V,R=S2,B),(R=V,B)):- var(S1),S1==S2. mize_body_2e(_Ctx,_,(S1=V,R=S2),(R=V)):- var(S1),S1==S2,(var(R);var(V)),S2='$error_this_was_eliminated',allowed_level(2). mize_body_2e(_Ctx,_,t_or_nil(G, R),G):- R==t,allowed_level(1). mize_body_2e(_Ctx,_,t_or_nil(G, R),\+ G):- R==[],allowed_level(1). mize_body_2e(_Ctx,_,(t_or_nil(G, R),(R \==[]-> B ; C)),(G->B;C)):- var(R),allowed_level(1). mize_body_2e(_Ctx,_,(t_or_nil(G, R),(R \==[])),G):- var(R),allowed_level(1). mize_body_2e(_Ctx,_,catch(G,block_exit(Label,Result),true),G):- nonvar(Label),var(Result),Label\==[],no_block_exists(G). mize_body_2e(_Ctx,_,(PARG,A=B), PARG):- wam_cl_option(elim_xvars,true),compound(PARG),functor(PARG,_,Ar),arg(Ar,PARG,PP),(A==PP;B==PP),!,A=B. mize_body_2e(_Ctx,_,G,true):- wam_cl_option(elim_always_trues,true), always_true(G). mize_body_2e(_Ctx,_,Var is Ground,Var = Result):- wam_cl_option(elim_vars,true), var(Var),ground(Ground), Result is Ground. % mize_body_2e(_Ctx,_,Number=:=Var,Number==Var):- (number(Number),var(Var));number(Var),var(Number),!. mize_body_2e(Ctx,_F,C1,C2):- compound_name_arguments(C1,F,C1O),must_maplist(mize_body2(Ctx,F),C1O,C2O),C2=..[F|C2O]. mize_body_2e(_Ctx,_,C1,C1):-!. %mize_body3(_Ctx,_,C1,C1):- var(C1),del_attr(C1,rwstate). mize_body3(_Ctx,_,C1=C2, true):- var(C1),var(C2),wam_cl_option(elim_vars,true),C1==C2,!. mize_body3(_Ctx,_,C1,C1):- non_compound_code(C1),!. %mize_body3(_Ctx,_F,(C1,A=B),C1):- ifthenelse(C1),var(A),var(B),A=B. mize_body3(Ctx,_F,C1,C2):- compound_name_arguments(C1,F,C1O),must_maplist(mize_body3(Ctx,F),C1O,C2O),C2=..[F|C2O]. mize_body3(_Ctx,_,C1,C1):-!. %env_mize(_Ctx,_,C1,C1):-!. env_mize(_Ctx,_,C1,C1):- non_compound_code(C1),!. env_mize(Ctx,F,C1,CodeOut):- C1 = ( Env=[bv(N, Var)|Rest], C2), var(Env),atom(N), Rest==[], \+ contains_var(N,C2), \+ contains_var(Env,C2), contains_var(Var,C2),!, env_mize(Ctx,F, C2,CodeOut),!. env_mize(Ctx,F,C1,CodeOut):- C1 = ( Env=[bv(N, Var)|Rest], C2), var(Env),atom(N), Rest\==[], \+ contains_var(N,C2), \+ contains_var(Env,C2), contains_var(Var,C2),!, env_mize(Ctx,F,( Env=Rest, C2),CodeOut). env_mize(Ctx,_F,C1,C2):- compound_name_arguments(C1,F,C1O),must_maplist(env_mize(Ctx,F),C1O,C2O),C2=..[F|C2O]. env_mize(_Ctx,_,C1,C1):-!. % inline_operation(_,_,_,C1,C1). inline_operation(_Never,_Ctx,_,C1,C1):- var(C1),!. inline_operation(_Never,_Ctx,_,Code,Out):- skip_optimize(Code),Out=Code. inline_operation(Never,Ctx,FF,(:-C1),(:-C2)):- inline_body(Never,Ctx,FF,C1,C2),C1\==C2,!. inline_operation(Never,Ctx,FF,(:-C1),(:-C2)):- inline_operation(Never,Ctx,FF,C1,C2). inline_operation(Never,Ctx,F,(C1,C2),CodeJoined):-!, inline_operation(Never,Ctx,F,C1,C1O), inline_operation(Never,Ctx,F,C2,C2O), conjoin_0(Ctx,C1O,C2O,CodeJoined). %inline_operation(Never,_Ctx,_,Code,Out):- functor(Code,F,N),member(F/N,Never),Out=Code. inline_operation(_Never,_Ctx,_FF,(H:-C1),(H:-C1)):- compound(C1), functor(C1,start_tabling,_),!. inline_operation(Never,Ctx,FF,(MH:-C1),(MH:-C2)):- strip_module(MH,_M,H),functor(H,F,A),atom_concat_or_rtrace(_,' tabled',F),!, inline_body([F/A|Never],Ctx,FF,C1,C2). inline_operation(Never,Ctx,FF,A,Wrapper):- is_assert_op(A,Where,MH:-C1), strip_module(MH,_,H), functor(H,F,A), inline_body([F/A|Never],Ctx,FF,C1,C2), Wrapper = assert_lsp(Where,(MH :- C2)). % assert_lsp/ (:- / 1) inline_operation(Never,Ctx,FF,PAB,Conjs):- PAB=..[F,C1|Rest], functor(PAB,F,A),functor_arg_is_body(F,A),!, inline_operation(Never,Ctx,FF,C1,C2), do_conjs(F,C2,Rest,Conjs). %inline_operation(_Never,_Ctx,_,C1,C1):-!. inline_operation(Never,Ctx,FF,(:-C1),(:-C2)):-!, inline_body(Never,Ctx,FF,C1,C2),!. inline_operation(_Never,_Ctx,_,C1,C1):-!. progress_g(G):- copy_term(G,GG),del_attrs_of(GG,dif),GG. ensure_tabled(M,H):- M:( (use_module(library(tabling))), (multifile('$tabled'/1)), %(dynamic('$tabled'/1)),assert_lsp(M:'$tabled'(H)), (multifile('$table_mode'/3)), (multifile('$table_update'/4)), always(prolog:'$flushed_predicate'(M:'$tabled'(_))), (always(prolog:call(M:'$tabled'(H))))). do_conjs(F,C1,Rest,Conjs):-var(C1),!,Conjs=..[F,C1|Rest]. do_conjs(_F,unwrapped(C2),_Rest,C2):-!. do_conjs(F,C1,Rest,C2):- !,do_conjs2(F,C1,Rest,C2). do_conjs2(F,(C1,C2),Rest,Conjs):- !, do_conjs(F,C1,Rest,P1),do_conjs(F,C2,Rest,P2),conjoin_0(_Ctx,P1,P2,Conjs). do_conjs2(F,C2,Rest,Conjs):- Conjs=..[F,C2|Rest]. stay_all_different(Out):- term_variables(Out,Vars), stay_all_different_vars(Vars),!. stay_all_different_vars([]). stay_all_different_vars([_]). stay_all_different_vars([X|Vars]):- maplist(dif(X),Vars),stay_all_different_vars(Vars). %inline_body(_,_,_,C1,C1). inline_body(_Never,_Ctx,_,C1,C1):- var(C1),!. inline_body(Never,Ctx,FT,(:-Body),(:-Out)):- !, inline_body(Never,Ctx,FT,Body,Out). inline_body(Never,Ctx,FT,(A,B),(AA,BB)):-!,inline_body(Never,Ctx,FT,A,AA),inline_body(Never,Ctx,FT,B,BB). inline_body(Never,Ctx,FT,(A;B),(AA;BB)):-!,inline_body(Never,Ctx,FT,A,AA),inline_body(Never,Ctx,FT,B,BB). inline_body(Never,Ctx,FT,(A->B),(AA->BB)):-!,inline_body(Never,Ctx,FT,A,AA),inline_body(Never,Ctx,FT,B,BB). inline_body(_Never,_Ctx,_,Code,Out):- \+ \+ skip_optimize(Code),!,Out=Code. %inline_body(Never,_Ctx,_,Code,Out):- compound(Code),functor(Code,F,N),member(F/N,Never),!,Out=Code. inline_body(Never,Ctx,FT,(M:Code:-Body),(M:Code:-Out)):- compound(Code),functor(Code,F,A),!,inline_body([F/A|Never],Ctx,FT,Body,Out). inline_body(Never,Ctx,F,C1,Out):- any_inline(Never,Ctx,F,C1,Out). inline_body(_Never,_Ctx,_,C1,C1):- non_compound_code(C1),!. inline_body(Never,Ctx,_F,C1,C2):- compound_name_arguments(C1,F,C1O), must_maplist(inline_body(Never,Ctx,F),C1O,C2O),!,C2=..[F|C2O]. inline_body(_Never,_Ctx,_F,C1,C1):-!. any_inline(_Never,_Ctx,_,In,Out):- simple_inline(In,Out),!. any_inline(Never,Ctx,F,C1,Out):- maybe_inline(C1), stay_all_different(C1), get_inlined(C1,MID),functor(C1,F,A), progress_g(dbginfo(inlined(C1):-MID)),!, sanitize_true(Ctx,MID,MID2), inline_body([F/A|Never],Ctx,F,MID2,Out),!. /* inline_body(_Never,_Ctx,_,In,Out):- stay_all_different(In),simple_inline(In,Out),!. inline_body(Never,Ctx,F,C1,Out):- maybe_inline(C1), stay_all_different(C1), get_inlined(C1,MID),functor(C1,F,A), progress_g(dbginfo(inlined(C1):-MID)),!, sanitize_true(Ctx,MID,MID2), inline_body([F/A|Never],Ctx,F,MID2,Out). inline_body(_Never,_Ctx,_,C1,C1):- non_compound_code(C1),!. inline_body(Never,Ctx,_F,C1,C2):- compound_name_arguments(C1,F,C1O), must_maplist(inline_body(Never,Ctx,F),C1O,C2O),!,C2=..[F|C2O]. inline_body(_Never,_Ctx,_F,C1,C1):-!. */ simple_inline(In,_Out):- \+ compound(In),!,fail. simple_inline(set_var(E, OP, N, V),set_var(E, N, V)):- atom(N),atom(OP),memberchk(OP,[psetq,setq]). simple_inline(set_place(E, OP, N, V),set_var(E, N, V)):- var(V), atom(N),atom(OP),memberchk(OP,[psetq,setq]). %simple_inline(set_var(E, OP, [PLACE, N], V),set_place(E, OP, [PLACE, N], V)):- var(V), atom(N),atom(OP),memberchk(OP,[setf]). simple_inline(f_list(A,B),B=A). %simple_inline(f_sys_pf_set_slot_value(A,B,C,D),set_slot(A,B,C)):-C=D. simple_inline(f_cdr(I,O),(I==[]->O=[];I=[_|O])):- wam_cl_option(debug,0). simple_inline(f_car(I,O),(I==[]->O=[];I=[O|_])):- wam_cl_option(debug,0). list_to_disj([C1],(C1O)):-!, list_to_disj(C1,C1O). list_to_disj([C1,C2],(C1O;C2O)):-!, list_to_disj(C1,C1O),list_to_disj(C2,C2O). list_to_disj([C1|C2],(C1O;C2O)):-!, list_to_disj(C1,C1O),list_to_disj(C2,C2O). list_to_disj(C1,C1). get_inlined(P,Out):- bagof(I,clause_interface(P,I),DisjL),list_to_disj(DisjL,Out),!. never_inline(P):- \+ callable(P),!. never_inline(P):- compound(P),functor(P,F,A),never_inline_fa(F,A),!. never_inline(P):- (predicate_property(P,number_of_clauses(N))->N==0;true),!. never_inline(P):- predicate_property(P,imported_from(system)),!. never_inline_fa(set_place,_). never_inline_fa(F,_):- atom_concat_or_rtrace(_,' tabled',F). never_inline_fa(start_tabling,_). never_inline_fa(get_var,_). never_inline_fa(f_sys_set_symbol_value,_). never_inline_fa(get_opv,_). never_inline_fa(member,_). never_inline_fa(as_rest,_). %never_inline_fa(t_or_nil,_). always_inline(P):- clause_interface(P,B),compound(B),B=t_or_nil(_,_),!. always_inline(P):- clause_interface(P,B),compound(B),B=is(_,_),!. always_inline(P):- compound(P),functor(P,F,A),always_inline_fa(F,A). always_inline_fa(F,1):- atom_concat_or_rtrace('addr_tagbody_',M,F),atom_contains(M,'_addr_enter_'). always_inline_fa(F,1):- atom_concat_or_rtrace('addr_tagbody_',_,F), functor(P,F,1), \+ clause_calls_self(P). always_inline_fa(F,_):- atom_concat_or_rtrace(_,'expand1',F). always_inline_fa(F,_):- atom_concat_or_rtrace('f_c',M,F),atom_concat_or_rtrace(_,'ar',M). always_inline_fa(F,_):- atom_concat_or_rtrace('f_c',M,F),atom_concat_or_rtrace(_,'dr',M). %maybe_inline(_):-!,fail. maybe_inline(_):- \+ (wam_cl_option(safe(inline),true);wam_cl_option(inline,true)),!,fail. maybe_inline(C1):- never_inline(C1),!,fail. maybe_inline(C1):- \+ predicate_property(C1,number_of_clauses(1)),!,fail. maybe_inline(C1):- clause_has_cuts(C1),!,fail. maybe_inline(C1):- wam_cl_option(safe(inline),true), always_inline(C1),!. maybe_inline(C1):- \+ predicate_property(C1,dynamic),!,fail. clause_has_cuts(P):- clause_interface(P,I),contains_var(!,I). clause_calls_self(P):- clause_interface(P,I),functor(P,F,A),functor(C,F,A),contains_term(E,I),compound(E),E=C. clause_interface(P,I):- predicate_property(P,number_of_clauses(_)), clause(P,I). clause_interface(P,I):- wl:pass_clause(_,P,I). clause_interface(P,I,R):- predicate_property(P,number_of_clauses(_)),clause(P,I,R). clause_interface(P,I,R):- wl:pass_clause(R,P,I). mize_prolog_code(In,Out):-skip_optimize(In),!,In=Out. mize_prolog_code(In,Out):- clause(mize_prolog_code1(In2,Out2),Body), structure_applies_here(In,In2,Body),!, (In \== Out2 -> mize_prolog_code(Out2,Out);Out=In),!. mize_prolog_code(InOut,InOut). mize_prolog_code1(maplist(_,[]),true). mize_prolog_code1(maplist(P,[X]),call(P,X)). mize_prolog_code1(call(F,A),Out):- atom(F),Out=..[F,A]. wcl:- profile(f_compile_file('$ARRAY'([*], claz_base_character, "wam-cl-init-1"))). :- fixup_exports.