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.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%