The code for the predicate uni is very close to the specification of the compilation scheme. In particular, the definition of un_list is an almost identical copy of Figure 2 of the compilation scheme. The peephole optimizer peep shows the use of scope and composition for accumulators (see the comment 'deep magic') to provide a more efficient closure operation. Both uni and peep are worth close study.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Compile psi-term unification using the two-stream algorithm. % For more information, see the paper by Hassan Ait-Kaci and Roberto DiCosmo: % "Compiling Order-Sorted Feature Term Unification with Sort Definitions", % which gives semantics for the instructions generated here. This code works % only for empty sort definitions. % The Half_Life compiler written by Richard Meyer contains an improved version % of this algorithm which handles all features of a term "at once". One % consequence is that the improved version has performance similar to Prolog % if the dynamic nature of psi-terms is not used at run-time. % If this code is put into the file unify_alg.lf, then it can be directly % loaded into wild_life with the query 'load("unify_alg")?'. % Copyright 1994 by Peter Van Roy % To ensure that the preprocessor is loaded: import("accumulators")? %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Some example compilations. % Example (1) from paper: ex1(X) :- uni(X:person(name => id(first => string, last => Y:string), spouse => person(name => id(last => Y), spouse => X))). ex2 :- uni(f(a)). ex3 :- uni(X:f(X)). ex4 :- uni(a(b(c(d)))). ex5 :- uni(a(b,c,d,e,f)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Unification compiler. % Two-stream compilation algorithm that has been extended to handle % feature terms. % Assumes all coref features point to *previous* coreferences % in a DF traversal, i.e., that all coreferences are initialized. % This is satisfied by psi2diss. acc_info(r, X,Out,In,acc_pred=>(Out=[X|In]))? acc_info(w, X,Out,In,acc_pred=>(Out=[X|In]))? acc_info(lab, X,Out,In,acc_pred=>(Out=[X|In]))? pred_info(un, [r,w,lab])? pred_info(un_list, [r,w,lab])? pred_info(un_coref, [r,w,lab])? % Writes code before and after peephole optimization. uni(T, Code:[init_test|C1]) :- psi2diss(T,P), un_top(P, 0, C1, Labels), init_genint, reg_alloc(regs), (lab_alloc(Labels),write_list(Code),nl,fail;true), peep(Code, Peep), lab_alloc(Labels), write_list(Peep). un_top(T, Level, Code, Labels) :-- (un(T,Level), jump(End)+r, label(End)+w, End+lab) with (@(Code,[]) = r=>w, lab(Labels,[]))? un(T:psi(features=>FL,register=>Rt,sort=>S), Level) :-- intersect_sort(Rt,S)+r, set_sort(Rt,S)+w, un_list(FL, T, Level+1)? un_list([], _, _) :-- !? un_list([feat(Fn,F)|FL], T, Level) :-- {T=psi(register=>Rt)}, {F=psi(register=>Rf,sort=>S)}, test_feature(Rt,Fn,Rf,Level,L)+r, label(L)+w, L+lab, push_cell(Rf)+w, set_feature(Rt,Fn,Rf)+w, un(F, Level), un_coref(F), label(L2)+r, L2+lab, write_test(Level,L2)+w, un_list(FL, T, Level)? un_coref(F) :-- {has_feature(coref,F)}, {F=psi(coref=>C:psi)}, !, {F=psi(register=>Rf)}, {C=psi(register=>Rc)}, unify(Rf,Rc)+r, unify(Rf,Rc)+w? un_coref(F) :-- succeed? %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Peephole optimization. % Do after register allocation and before label instantiation. % Does closure. acc_info(in, X,Out,In,acc_pred=>(Out=[X|In]))? acc_info(out, X,Out,In,acc_pred=>(Out=[X|In]))? acc_info(changes,X,In,Out,acc_pred=>(Out=In+X))? pred_info(peep_loop, [in,out,changes])? pred_info(peep_one, [in,out,changes])? peep(In, Out) :-- peep_loop with (in(In,[]), out(Mid,[]), changes(0,C)), write(C), cond(C=:=0, (nl,Out=Mid), (write(" "),peep(Mid, Out)))? peep_loop :-- % The following 'deep magic' can be left out (keep only the call to % 'peep_one') without changing correctness. Putting it in will reduce % the number of passes needed to achieve closure by prefixing the % peepholed instructions to the input list and continuing with that. % (Instead of doing a full pass before looking again at the peepholed % instructions.) % Deep magic starts here peep_one with (glob(in) = in=>inv(out)), % Deep magic ends here !, 1+changes, peep_loop? % peep_loop :-- peep_one, !, 1+changes, peep_loop? peep_loop :-- [] is in, !, [] is out? peep_loop :-- I+in, I+out, peep_loop? peep_one :-- push_cell(R1)+in, set_feature(R3,Fn,R1)+in, set_sort(R1,"@")+in, unify(R1,R2)+in, !, set_feature(R3,Fn,R2)+out? peep_one :-- label(L)+in, jump(L)+in, !, jump(L)+out? peep_one :-- intersect_sort(_,"@")+in, !? peep_one :-- jump(L)+in, I+in, {\+I=label(_)}, !, jump(L)+out? peep_one :-- jump(L1)+in, label(L2)+in, {L1===L2}, !, label(L2)+out? peep_one :-- write_test(I,L1)+in, label(L2)+in, {L1===L2}, !, label(L2)+out? peep_one :-- label(L)+in, label(L)+in, !, label(L)+out? peep_one :-- write_test(I,L1)+in, write_test(J,L2)+in, {L1===L2}, {I>=J}, !, write_test(J,L1)+out? %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Dissolving a psi-term. % This routine is a basic primitive in the compiler. % It "wraps" a psi-term to make it easily manipulable in % later passes of the compiler. % The term S(foo=>P) becomes: % psi(sort=>"S",features=>[feat("foo",P),...],register=>R,name=>N,coref=>end) % for the representative of a coref set, and % psi(register=>R,name=>N,coref=>T) % for all other members of the coref set (where T refers to the representative). % The representative is always encountered *first* in a DF traversal % of the term. % A syntactic convenience: global(sf)? % For detecting cycles in a psi-term global(regs)? % The set of registers (one per psi-term) global(names)? % Names of all psi-terms % Dissolve psi-term to another where sorts, features, and corefs % are made explicit. (Must quote P's that are evaluable.) % non_strict(psi2diss)? psi2diss(P,T) :- sf<-[pair(P,T)], regs<-[], names<-[], psi2dissolve(P,T). % Psiterm has at least a register and a name. % (Non-corefs have also a sort and a list of features) newpsi(T) -> cond(has_feature(register,T), T, (T & psi(register=>Reg,name=>Name) | regs<-[Reg|copy_pointer(regs)], names<-[Name|copy_pointer(names)] )). psi2dissolve(P,newpsi(T:psi(sort=>psi2str(root_sort(P)),features=>Fs))) :- psi2dissolve_list(features(P), P, Fs). psi2dissolve_list([], P, []) :- !. psi2dissolve_list([F|FL], P, [feat(S,T)|NewFs]) :- X=project(F,P), S=psi2str(F), cond(inv(X,sf,U), % Mark T and U as coreferenced psi-terms (newpsi(U)=psi(coref=>end), newpsi(T)=psi(coref=>U) ), (sf<-[pair(X,T)|copy_pointer(sf)], psi2dissolve(X, T) ) ), psi2dissolve_list(FL, P, NewFs). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Utilities. tab :- put(9). init_genint :- setq(genint_counter,0). % Check object membership in a list of pairs; return other member. % (Uses naive linear search) inv(X, [], _) -> false. inv(X, [pair(Y,Ti)|L], To) -> cond(X===Y, (true|Ti=To), inv(X,L,To)). % Simple register allocator: reg_alloc([]) :- !. reg_alloc([R|L]) :- reg_alloc(L), R=r(genint). % Generate a new label: genlab -> l(genint). % Simple label allocator: lab_alloc([]) :- !. lab_alloc([{genlab;@}|L]) :- !, lab_alloc(L). % Write a list of instructions in pretty fashion: write_list([]) :- !, nl. write_list([X|L]) :- write_inst(X), write_list(L). write_inst(label(L)) :- !, write(L),write(":"). write_inst(I) :- tab,writeq(I),nl. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%