yap-6.3/misc/buildops

:- use_module(library(lineutils),
	[process/2,
	 split/3]).

:- use_module(library(readutil),
	[read_line_to_codes/2]).

:- use_module(library(charsio),
	[format_to_chars/3]).

:- use_module(library(lists),
	[member/2]).

:- initialization(main).

:- yap_flag(write_strings,on).

:- yap_flag(unknown,error).

:- style_check(all).

:- dynamic qual/1.

qual("none").

main :-
	get_field_names('H/amidefs.h'),
	open('H/YapOpcodes.h',write,W),
	open('H/rclause.h',write,C),
	open('H/walkclause.h',write,L),
	open('H/findclause.h',write,F),
	open('H/headclause.h',write,H),
	open('H/saveclause.h',write,S),
	header(W),
	header_rclause(C),
	header_walk_clause(L),
	header_find_clause(F),
	header_find_clause(H),
	header_save_clause(S),
	file('C/absmi.c', W, C, L, F, H, S),
	start_ifdef("YAPOR", W, C, L, F, H, S),
	file('OPTYap/or.insts.i',W, C, L, F, H, S),
	end_ifdef(W, C, L, F, H, S),
	start_ifdef("TABLING", W, C, L, F, H, S),
	file('OPTYap/tab.insts.i',W,C,L, F, H, S),
	retractall(op(_,_)),
	file('OPTYap/tab.tries.insts.i', W, C, L, F, H, S),
	end_ifdef(W, C, L, F, H, S),
	footer(W),
	footer_rclause(C),
	footer_walk_clause(L),
	footer_find_clause(F),
	footer_find_clause(H),
	footer_save_clause(S),
	close(F),
	close(L),
	close(W),
	close(C),
	close(H),
	close(S).

start_ifdef(D, W, C, L, F, H, S) :-
	retractall(op(_,_)),
	format(W, '#ifdef ~s~n',[D]),
	format(C, '#ifdef ~s~n',[D]),
	format(L, '#ifdef ~s~n',[D]),
	format(F, '#ifdef ~s~n',[D]),
	format(H, '#ifdef ~s~n',[D]),
	format(S, '#ifdef ~s~n',[D]).
	
end_ifdef(W,C,L,F,H, S) :-
	format(W, '#endif~n',[]),
	format(C, '#endif~n',[]),
	format(L, '#endif~n',[]),
	format(F, '#endif~n',[]),
	format(H, '#endif~n',[]),
	format(S, '#endif~n',[]).

header(W) :-
	format(W,'~n  /* This file was generated automatically by \"yap -L misc/buildops\"~n     please do not update */~n~n',[]).


header_rclause(W) :-
	format(W,'~n  /* This file was generated automatically by \"yap -L misc/buildops\"~n     please do not update */~n~n
static void 
restore_opcodes(yamop *pc, yamop *max USES_REGS)
{
  yamop *opc = NULL;
  do {
    op_numbers op;
    if (max && pc >= max) return;
    op = Yap_op_from_opcode(pc->opc);
    pc->opc = Yap_opcode(op);
#ifdef DEBUG_RESTORE2
    fprintf(stderr, "%s ", Yap_op_names[op]);
#endif
    switch (op) {
',[]).

header_walk_clause(W) :-
	format(W,'~n  /* This file was generated automatically by \"yap -L misc/buildops\"~n     please do not update */~n~n
  while (TRUE) {
    op_numbers op;

    op = Yap_op_from_opcode(pc->opc);
    /* C-code, maybe indexing */
    switch (op) {
',[]).

header_save_clause(W) :-
	format(W,'~n  /* This file was generated automatically by \"yap -L misc/buildops\"~n     please do not update */~n~n
  while (TRUE) {
    op_numbers op;
    if (max && pc >= max) return 1;
    op = Yap_op_from_opcode(pc->opc);
    save_Opcode(stream, op);

    /* C-code, maybe indexing */
    switch (op) {
',[]).

header_find_clause(W) :-
	format(W,'~n  /* This file was generated automatically by \"yap -L misc/buildops\"~n     please do not update */~n~n
  while (TRUE) {
    op_numbers op = Yap_op_from_opcode(cl->opc);
    switch (op) {
',[]).


file(I,W,C,L,F,H, S) :-
	open(I,read,R),
	process(R,grep_opcode(W)),
	close(R),
	output_rclause(C),
	output_walk_clause(L),
	output_find_clause(F),
	output_head_clause(H),
	output_save_clause(S).

grep_opcode(W, Line) :-
%format('~s~n', [Line]),
	split(Line," 	,();",[OP,Name,Type]),
	Name \= "or_last",
	check_op(OP),
	special(Name,W),
	assert(op(Type,Name)),
	format(W,'  OPCODE(~s~36+,~s),~n',[Name,Type]),
	end_special(Name,W).

check_op("Op").
check_op("BOp").
check_op("PBOp").
check_op("OpRW").
check_op("OpW").

special(Name, W) :-
	special_op(Name, Decl), !,
	format(W,"#ifdef ~s~n",[Decl]).
special(_, _).

end_special(Name, W) :-
	special_op(Name, _), !,
	format(W,"#endif~n",[]).
end_special(_, _).

special_op("clause_with_cut","TABLING_INNER_CUTS").
special_op("table_answer_resolution_completion","THREADS_CONSUMER_SHARING").
special_op("cut_c","CUT_C").
special_op("cut_userc","CUT_C").
special_op("run_eam","BEAM").
special_op("retry_eam","BEAM").
special_op("thread_local","THREADS").

output_rclause(C) :-
	setof(T,O^op(T,O),Types),
	member(T, Types),
	output_type(T, C),
	fail.
output_rclause(_).

output_type(T, C) :-
	format(C,'      /* instructions type ~s */~n',[T]),
	setof(Op,op(T,Op),Ops),
	dump_ops(C,Ops),
	output_typeinfo(C,T).


output_typeinfo(C,T) :-
	tinfo(T, Info),
	dump_fields(C,Info,T,T),
	special_formats(C,T), !,
	format(C,'      pc = NEXTOP(pc,~s);
      break;~n',[T]).
output_typeinfo(_,_).

% tables require access to the table info. 
special_formats(C,"e") :- !,
	format(C,'      if (op == _Nstop || op == _copy_idb_term || op == _unify_idb_term) return;~n',[]).
special_formats(C,"l") :- !,
	format(C,'      if (op == _Ystop) return;~n',[]).
special_formats(C,"sssl") :- !,
	format(C,'      AdjustSwitchTable(op, pc->u.sssl.l, pc->u.sssl.s);~n',[]).
special_formats(C,"Illss") :- !,
	format(C,'      opc = NEXTOP(pc,Illss);
      pc = pc->u.Illss.l1;
      break;~n',[]),
	% don't go to NEXTOP
	fail.
special_formats(C,"OtaLl") :- !,
	format(C,'      pc = pc->u.OtaLl.n;
      break;~n',[]),
	% don't go to NEXTOP
	fail.
special_formats(C,"OtILl") :- !,
	format(C,'      pc = opc;
      break;~n',[]),
	% don't go to NEXTOP
	fail.
special_formats(_,_).

dump_fields(_,[],"e",_).
dump_fields(_,[],[],_).
dump_fields(C,[I-_|Info],[O|Ops],T) :- !,
	dump_field(C,I,O,T),
	dump_fields(C,Info,Ops,T).
dump_fields(C,[_|Info],Ops,T) :-
	dump_fields(C,Info,Ops,T).

dump_field(C,I,O,T) :-
	rewritable_field(O), !,
	get_op(O,A),
	format(C,'      ~sAdjust(pc->u.~s.~s);~n',[A,T,I]).
dump_field(C,I,O,T) :-
	get_op(O,A),
	format(C,'      pc->u.~s.~s = ~sAdjust(pc->u.~s.~s);~n',[T,I,A,T,I]).

rewritable_field(0'd).
rewritable_field(0'i).
rewritable_field(0'O).
rewritable_field(0't).


get_op(0'a,"Arity").
get_op(0'b,"CellPtoHeap").
get_op(0'c,"ConstantTerm").
get_op(0'd,"DoubleInCode").
get_op(0'D,"DBGroundTerm").
get_op(0'f,"Func").
get_op(0'F,"ExternalFunction").
get_op(0'i,"IntegerInCode").
get_op(0'I,"PtoLUIndex").
get_op(0'l,"PtoOp").
get_op(0'L,"PtoLUClause").
get_op(0'm,"Module").
get_op(0'n,"Integer").
get_op(0'N,"BlobTermInCode").
get_op(0'o,"Opcode").
get_op(0'O,"OrArg").
get_op(0'p,"PtoPred").
get_op(0's,"Constant").
get_op(0't,"TabEntry").
get_op(0'x,"X").
get_op(0'y,"Y").
% '

dump_ops(_,[]).
dump_ops(C,[Op|Ops]) :-
	dump_op(C,Op),
	dump_ops(C,Ops).

dump_op(C,Op) :-
	special(Op,C),
	format(C,'    case _~s:~n',[Op]),
	end_special(Op,C).

output_walk_clause(L) :-
	setof(T,O^op(T,O),Types),
	member(T, Types),
	output_walk_type(T, L),
	fail.
output_walk_clause(_).

%
% Walk the absmi code looking for the current predicate,
% the current beginning and the current end of the clause.
% This goes by skipping ops until we find a op which knows where the
% clause starts. Usually this is Ystop.
% We also take pains to stop and check if we find out the current predicate.
% Some instructions know it.
%
% Most instructions should not care less about what happens here!
%

output_walk_type(T, C) :-
	format(C,'      /* instructions type ~s */~n',[T]),
	setof(Op,op(T,Op),Ops0),
	split_ops(Ops0,Ops1,Ops2),
	( split_ops1(T, Ops1, Ops) ; Ops2 = Ops ),
	Ops = [_|_],
	% first send the header
	dump_ops(C,Ops),
	% then the code for every instruction with this header.
	output_walk(C,T,Ops).

% separate a special group of instructions, that operate differentely from the
% rest of the format.
split_ops([],[],[]).
split_ops([Op|Ops0],[Op|Ops1],Ops2) :-
	special_walk_op(Op), !,
	split_ops(Ops0,Ops1,Ops2).
split_ops([Op|Ops0],[Op|Ops1],Ops2) :-
	c_call_op(Op), !,
	split_ops(Ops0,Ops1,Ops2).
split_ops([Op|Ops0],Ops1,[Op|Ops2]) :-
	split_ops(Ops0,Ops1,Ops2).

split_ops1("e", Ops, [M]) :- !,
	member(M, Ops).
split_ops1("Osbpp", Ops, [M]) :- !,
	member(M, Ops).
split_ops1(_, Ops, Ops).

% instructions which require special treatment, relative to
% other instructions with the same format
special_walk_op("p_execute").
special_walk_op("p_execute2").
special_walk_op("p_execute_tail").
special_walk_op("procceed").
special_walk_op("lock_lu").
special_walk_op("Nstop").
special_walk_op("Ystop").
special_walk_op("expand_index").
special_walk_op("undef_p").
special_walk_op("spy_pred").
special_walk_op("index_pred").
special_walk_op("lock_pred").
special_walk_op("op_fail").
special_walk_op("trust_fail").
special_walk_op("unify_idb_term").
special_walk_op("copy_idb_term").

c_call_op("call_cpred").
c_call_op("call_usercpred").
c_call_op("execute_cpred").
c_call_op("call_c_wfail").

% I field gives direct access to LU index block and to all Pred information
output_walk(C,"Illss",_) :- !,
	format(C,'      return walk_got_lu_block(pc->u.Illss.I, startp, endp);~n',[]).
output_walk(C,"OtILl",_) :- !,
	format(C,'      return walk_got_lu_block(pc->u.OtILl.block, startp, endp);~n',[]).
% I field gives direct access to LU index clause and to all Pred information
output_walk(C,"L",_) :- !,
	format(C,'      return walk_got_lu_clause(pc->u.L.ClBase, startp, endp);~n',[]).
 % we cannot jump to clause code.
output_walk(C,"OtaLl",_) :- !,
	format(C,'      pc = pc->u.OtaLl.n;~n      break;~n',[]).
% ops which point at the clause's predicate.
output_walk(C,"Osblp",_) :- !,
	label_in_clause(C,"Osblp","p0").
output_walk(C,"Osbpp",[Op|_]) :-
	c_call_op(Op), !,
	walk_to_c_code(C,"Osbpp","p").
output_walk(C,"slp",[Op|_]) :-
	c_call_op(Op), !,
	walk_to_c_code(C,"slp","p").
output_walk(C,"Osbpp",[Op|_]) :-
	special_walk_op(Op), !,
	walk_to_meta_call(C).
output_walk(C,"Osbpp",_) :- !,
	label_in_clause(C,"Osbpp","p0").
output_walk(C,"pp",[Op|_]) :-
	c_call_op(Op), !,
	walk_to_c_code(C,"pp","p").
output_walk(C,"pp",_) :- !,
	label_in_clause(C,"pp","p0").
output_walk(C,"OtapFs",_) :- !,
	label_in_clause(C,"OtapFs","p").
output_walk(C,"Otapl",_) :- !,
	label_in_index(C,"Otapl","p").
output_walk(C,"p",["retry_profiled"|_]) :- !,
	add_pi(C,"p","p"),
	format(C,'      break;~n',[]).
output_walk(C,"p",[Op|_]) :-
	special_walk_op(Op), !,
	add_pp(C,"p","p"),
	format(C,'      break;~n',[]).
output_walk(C,"e",[Op|Ops]) :-
	special_walk_op(Op), !, % Nstop and friends
	output_ewalks(C,[Op|Ops]).
output_walk(C,"sssllp",[Op|Ops]) :-
	format(C,'      return found_expand_index(pc, startp, endp, codeptr PASS_REGS);~n',[]),
	output_ewalks(C,[Op|Ops]).
output_walk(C,"l",[Op|_]) :-
	special_walk_op(Op), !, % IDB
	format(C,'      return found_ystop(pc, clause_code, startp, endp, pp PASS_REGS);~n',[]).
output_walk(C,T,_) :-
	format(C,'      pc = NEXTOP(pc,~s);
      break;~n',[T]).

% There are so many weird empty instructions that we process
% each one separately.
output_ewalks(_,[]).
output_ewalks(C,["Nstop"|Ops]) :-
	format(C,'      return NULL;~n',[]),
	output_ewalks(C,Ops).
output_ewalks(C,["unify_idb_term"|Ops]) :-
	format(C,'      return found_idb_clause(pc, startp, endp);~n',[]),
	output_ewalks(C,Ops).
output_ewalks(C,["copy_idb_term"|Ops]) :-
	format(C,'      return found_idb_clause(pc, startp, endp);~n',[]),
	output_ewalks(C,Ops).
output_ewalks(C,["undef_p"|Ops]) :-
	format(C,'      return found_owner_op(pc, startp, endp PASS_REGS);~n',[]),
	output_ewalks(C,Ops).
output_ewalks(C,["spy_pred"|Ops]) :-
	format(C,'      return found_owner_op(pc, startp, endp PASS_REGS);~n',[]),
	output_ewalks(C,Ops).
output_ewalks(C,["expand_index"|Ops]) :-
	format(C,'      return found_expand(pc, startp, endp PASS_REGS);~n',[]),
	output_ewalks(C,Ops).
output_ewalks(C,["index_pred"|Ops]) :-
	format(C,'      return found_owner_op(pc, startp, endp PASS_REGS);~n',[]),
	output_ewalks(C,Ops).
output_ewalks(C,["lock_pred"|Ops]) :-
	format(C,'      return found_owner_op(pc, startp, endp PASS_REGS);~n',[]),
	output_ewalks(C,Ops).
output_ewalks(C,["op_fail"|Ops]) :-
	format(C,'      if (codeptr == FAILCODE)
        return found_fail(pc, startp, endp PASS_REGS);~n',[]),
	format(C,'      pc = NEXTOP(pc,~s);
      break;~n',["e"]),
	output_ewalks(C,Ops).
output_ewalks(C,["trust_fail"|Ops]) :-
	format(C,'      if (codeptr == TRUSTFAILCODE)
        return found_fail(pc, startp, endp PASS_REGS);~n',[]),
	format(C,'      pc = NEXTOP(pc,~s);
      break;~n',["e"]),
	output_ewalks(C,Ops).

label_in_clause(C,Type,Field) :-
	format(C,'      clause_code = TRUE;~n',[]),
	format(C,'      pp = pc->u.~s.~s;~n',[Type,Field]),
	format(C,'      pc = NEXTOP(pc,~s);
      break;~n',[Type]).

label_in_index(C,Type,Field) :-
	format(C,'      clause_code = FALSE;~n',[]),
	format(C,'      pp = pc->u.~s.~s;~n',[Type,Field]),
	format(C,'      pc = NEXTOP(pc,~s);
      break;~n',[Type]).

add_pi(C,Type,Field) :-
	format(C,'      pp = pc->u.~s.~s;~n',[Type,Field]),
	format(C,'      clause_code = FALSE;~n',[]),
	format(C,'      pc = NEXTOP(pc,~s);~n',[Type]).

add_pp(C,Type,Field) :-
	format(C,'      pp = pc->u.~s.~s;~n',[Type,Field]),
	format(C,'      if (pp->PredFlags & MegaClausePredFlag)~n',[]),
	format(C,'        return found_mega_clause(pp, startp, endp);~n',[]),
	format(C,'      clause_code = TRUE;~n',[]),
	format(C,'      pc = NEXTOP(pc,~s);~n',[Type]).

walk_to_meta_call(C) :-
	format(C,'      return found_meta_call(startp, endp);~n',[]).

walk_to_c_code(C,Type,Field) :-
	format(C,'      pp = pc->u.~s.~s;~n',[Type,Field]),
	format(C,'      return walk_found_c_pred(pp, startp, endp);~n',[]).

%
% find region
% tries to find out what an instruction touches in the body
% of a clause
%

output_find_clause(L) :-
	setof(T:Op,op(T,Op),Ops),
	member(T:Op, Ops),
	output_find_op(Op, T, L),
	fail.
output_find_clause(_).

output_find_op(Op, T, L) :-
	opinfo(Op, Actions),
	dump_op(L,Op),
	dump_actions(Actions, Op, T, L).

dump_actions([], _, T, L) :-
	format(L,'      cl = NEXTOP(cl,~s);~n',[T]),
	format(L,'      break;~n',[]).
dump_actions([A|Actions], Op, T, L) :-
	dump_action(A, Op, T, L),
	dump_actions(Actions, Op, T, L).

% conditional jumps can 
dump_action(body, _, _, _).
dump_action(ifthenelse, _, T, L) :-
	format(L,'      if (cl->u.~s.F != FAILCODE) {
	clause->Tag = (CELL)NULL;
	return;
      }~n', [T]).
dump_action(bind(Who,What,Extra), _, T, L) :-
	integer(Who), !,
	handle_bind_extra(Extra, T, Command),
	handle_constant(What, T, Constant),
	check_atom_dbref(What, Constant, ExtraAction),
	format(L,'      if (is_regcopy(myregs, nofregs, Yap_regnotoreg(~d))) {
	~sclause->Tag = ~s;~s
	return;
      }~n', [Who, ExtraAction, Constant, Command]).
dump_action(bind(Who,What,Extra), _, T, L) :-
	handle_bind_extra(Extra, T, Command),
	handle_constant(What, T, Constant),
	check_atom_dbref(What, Constant, ExtraAction),
	format(L,'      if (is_regcopy(myregs, nofregs, cl->u.~s.~s)) {
	~sclause->Tag = ~s;~s
	return;
      }~n', [T, Who, ExtraAction, Constant, Command]).
dump_action(new(Who), _, T, L) :-
	format(L,'      if (!(nofregs = delete_regcopy(myregs, nofregs, cl->u.~s.~s))) {
	clause->Tag = (CELL)NULL;
	return;
      }~n', [T,Who]).
dump_action(dup(Who1,Who2), _, T, L) :-
	format(L,'      if (!(nofregs = add_regcopy(myregs, nofregs, cl->u.~s.~s, cl->u.~s.~s))) {
	clause->Tag = (CELL)NULL;
	return;
      }~n', [T,Who1,T,Who2]).
dump_action(unify(Who1,Who2), _, T, L) :-
	format(L,'      if (!(nofregs = link_regcopies(myregs, nofregs, cl->u.~s.~s, cl->u.~s.~s))) {
	clause->Tag = (CELL)NULL;
	return;
      }~n', [T,Who1,T,Who2]).
dump_action(logical, _, _, L) :-
	format(L,'      if (regno == 2) {
	LogUpdClause *lcl = ClauseCodeToLogUpdClause(cl);
	Term t = lcl->ClSource->Entry;
	if (IsVarTerm(t)) {
	  clause->Tag = (CELL)NULL;
	} else if (IsApplTerm(t)) {
	  CELL *pt = RepAppl(t);

	  clause->Tag = AbsAppl((CELL *)pt[0]);
	  clause->u.c_sreg = pt;
	} else if (IsPairTerm(t)) {
	  CELL *pt = RepPair(t);

	  clause->Tag = AbsPair(NULL);
	  clause->u.c_sreg = pt-1;
	} else {
	  clause->Tag = t;
	}
      } else {
	clause->Tag = (CELL)NULL;
      }
      return;~n', []).


%
% atoms may actually be dbrefs :(
check_atom_dbref(Constant, What, ExtraAction) :-
	Constant = [0'c|_],  !, %0'c
	format_to_chars("if (IsApplTerm(~s)) {
          CELL *pt = RepAppl(~s);
	  clause->Tag = AbsAppl((CELL *)pt[0]);
	  clause->u.t_ptr = ~s;
	} else
	  ",[What,What,What], ExtraAction).	
check_atom_dbref(_, _, "").

handle_bind_extra([], _, "").
handle_bind_extra(t_ptr=[], _,S) :- !,
	format_to_chars("~n	clause->u.t_ptr = (CELL)NULL;",[],S).
handle_bind_extra(t_ptr=F, Type, S) :-
	format_to_chars("~n	clause->u.t_ptr = AbsAppl(cl->u.~s.~s);",[Type,F],S).
handle_bind_extra(workpc=nextop, T,S) :-
	format_to_chars("~n	clause->u.WorkPC = NEXTOP(cl,~s);",[T],S).
handle_bind_extra(workpc=currentop, _,S) :-
	format_to_chars("~n	clause->u.WorkPC = cl;",[],S).

handle_constant(What, T, Const) :-
	What = [C|_],
	(
	 C == 0'A  % 0'Abs
	->
	 Const = What
	;
	 C == 0'(  % 0'(
	->
	 Const = What
	;
	 format_to_chars("cl->u.~s.~s",[T,What],Const)
	).

%
% find head, works much faster by not looking inside
% tries to find out what an instruction touches in the body
% of a clause
%

output_head_clause(L) :-
	setof(T:Op,op(T,Op),Ops),
	member(T:Op, Ops),
	output_head_op(Op, T, L),
	fail.
output_head_clause(_).

output_head_op(Op, T, L) :-
	opinfo(Op, Actions),
	\+ member(body, Actions),
	dump_op(L,Op),
	dump_head_actions(Actions, Op, T, L).

dump_head_actions([], _, T, L) :-
	format(L,'      cl = NEXTOP(cl,~s);~n',[T]),
	format(L,'      break;~n',[]).
dump_head_actions([A|Actions], Op, T, L) :-
	dump_head_action(A, Op, T, L),
	dump_head_actions(Actions, Op, T, L).

% only simple stuff
dump_head_action(bind(Who,_,_), _, _, _) :- Who = [0'y|_], !. % 0'y
dump_head_action(bind(Who,What,Extra), _, T, L) :-
	integer(Who), !,
	handle_bind_extra(Extra, T, Command),
	handle_constant(What, T, Constant),
	check_atom_dbref(What, Constant, ExtraAction),
	format(L,'      if (iarg == Yap_regnotoreg(~d)) {
	~sclause->Tag = ~s;~s
	return;
      }~n', [Who,ExtraAction,Constant,Command]).
dump_head_action(bind(Who,What,Extra), _, T, L) :-
	handle_constant(What, T, Constant),
	handle_bind_extra(Extra, T, Command),
	check_atom_dbref(What, Constant, ExtraAction),
	format(L,'      if (iarg == cl->u.~s.~s) {
	~sclause->Tag = ~s;~s
	return;
      }~n', [T,Who,ExtraAction,Constant,Command]).
dump_head_action(new(Who), _, _, _) :- Who = [0'y|_], !. % 0'y done
dump_head_action(new(Who), _, T, L) :-
	format(L,'      if (iarg == cl->u.~s.~s) {
	clause->Tag = (CELL)NULL;
	return;
      }~n', [T,Who]).
dump_head_action(dup(Who1,Who2), _, T, L) :- Who1 = [0'y|_], !, % 0'y done
	format(L,'      if (cl->u.~s.~s == iarg) {
	clause->Tag = (CELL)NULL;
	return;
      }~n', [T,Who2]).
dump_head_action(dup(Who1,Who2), _, T, L) :- Who2 = [0'y|_], !, % 0'y done
	format(L,'      if (cl->u.~s.~s == iarg) {
	clause->Tag = (CELL)NULL;
	return;
      }~n', [T,Who1]).
dump_head_action(dup(Who1,Who2), _, T, L) :-
	format(L,'      if (cl->u.~s.~s == iarg ||
        cl->u.~s.~s == iarg) {
	clause->Tag = (CELL)NULL;
	return;
      }~n', [T,Who1,T,Who2]).
dump_head_action(unify(Who1,Who2), _, T, L) :- Who1 = [0'y|_], !, % 0'y done
	format(L,'      if (cl->u.~s.~s == iarg) {
	clause->Tag = (CELL)NULL;
	return;
      }~n', [T,Who2]).
dump_head_action(unify(Who1,Who2), _, T, L) :- Who2 = [0'y|_], !, % 0'y done
	format(L,'      if (cl->u.~s.~s == iarg) {
	clause->Tag = (CELL)NULL;
	return;
      }~n', [T,Who1]).
dump_head_action(unify(Who1,Who2), _, T, L) :-
	format(L,'      if (cl->u.~s.~s == iarg ||
        cl->u.~s.~s == iarg) {
	clause->Tag = (CELL)NULL;
	return;
      }~n', [T,Who1,T,Who2]).
dump_head_action(logical, _, _, L) :-
	format(L,'      if (regno != 2) {
	clause->Tag = (CELL)NULL;
      } else {
	LogUpdClause *lcl = ClauseCodeToLogUpdClause(cl);
	Term t = lcl->ClSource->Entry;
      
	if (IsVarTerm(t)) {
	  clause->Tag = (CELL)NULL;
	} else if (IsApplTerm(t)) {
	  CELL *pt = RepAppl(t);
	
	  clause->Tag = AbsAppl((CELL *)pt[0]);
	  if (IsExtensionFunctor(FunctorOfTerm(t))) {
	    clause->u.t_ptr = t;
	  } else {
	    clause->u.c_sreg = pt;
	  }
	} else if (IsPairTerm(t)) {
	  CELL *pt = RepPair(t);

	  clause->Tag = AbsPair(NULL);
	  clause->u.c_sreg = pt-1;
	} else {
	  clause->Tag = t;
	}
      }
      return;~n', []).
	
/* or_last requires special handling */
footer(W) :-
	format(W,'  /* this instruction is hardwired */~n',[]),
	format(W,'#ifdef YAPOR~n',[]),
	format(W,'  OPCODE(~s~36+,~s)~n',["or_last","sblp"]),
	format(W,'#else~n',[]),
	format(W,'  OPCODE(~s~36+,~s)~n',["or_last","p"]),
	format(W,'#endif~n',[]).


footer_rclause(W) :-
	format(W,'      /* this instruction is hardwired */~n',[]),
	dump_ops(W,["or_last"]),
	format(W,'#ifdef YAPOR~n',[]),
	output_typeinfo(W,"Osblp"),
	format(W,'#else~n',[]),
	output_typeinfo(W,"p"),
	format(W,'#endif~n',[]),
	format(W,'    }
  } while (TRUE);
}
',[]).

footer_walk_clause(W) :-
	format(W,'      /* this instruction is hardwired */~n',[]),
	dump_ops(W,["or_last"]),
	format(W,'#ifdef YAPOR~n',[]),
	add_pp(W,"Osblp","p0"),
	format(W,'#else~n',[]),
	add_pp(W,"p","p"),
	format(W,'#endif~n',[]),
	format(W,'    }
  }
',[]).

footer_find_clause(W) :-
	format(W,'default:
	clause->Tag = (CELL)NULL;
	return;
     }
  }~n',[]).

footer_save_clause(S) :-
	format(S,'default:
	return -1;
     }
  }~n',[]).

get_field_names(F) :-
	open(F, read, A),
	loop_for_fields(A),
	close(A).

loop_for_fields(A) :-
	read_line_to_codes(A,"typedef struct yami {"), !,
	loop_for_fields_go(A).
loop_for_fields(A) :-
	loop_for_fields(A).

loop_for_fields_go(A) :-
	read_line_to_codes(A,_),
	read_line_to_codes(A,_),
	read_field_by_field(A).

read_field_by_field(A) :-
	read_line_to_codes(A,L),
	split(L," 	",Statement),
	read_field_by_field(A,Statement).

read_field_by_field(_,["}","u;"]) :- !.
read_field_by_field(A,["struct","{"]) :- !,
	read_fields(A,Fields,Type),
	assert(tinfo(Type,Fields)),
	read_field_by_field(A).
read_field_by_field(A,_) :-
	read_field_by_field(A).

read_fields(A,Fields,Type) :-
	read_line_to_codes(A,L),
	split(L," 	;*[",Statements0),
	clean_statements(Statements0, Statements),
	( Statements = ["}",Type]
	->
	  Fields = []
	;
	  Statements = ["CELL","next"]
	->
	  read_fields(A,Fields,Type)
	;
	  Statements = ["/"|_]
	->
	  read_fields(A,Fields,Type)
	;
	  Statements = ["#ifdef",If]
	->
	  retract(qual(_)),
	  assert(qual(If)),
	  read_fields(A,Fields,Type)
	;
	  Statements = ["#endif"|_]
	->
	  retract(qual(_)),
	  assert(qual("none")),
	  read_fields(A,Fields,Type)
	;
	  Statements = [_,F|_],
	  qual(Qual),
	  Fields = [F-Qual|More],
	  read_fields(A,More,Type)
	).
	
	
	
clean_statements(["struct"|Statements0], StatementsF) :- !,
	clean_statements(Statements0, StatementsF).
clean_statements(["unsigned"|Statements0], StatementsF) :- !,
	clean_statements(Statements0, StatementsF).
clean_statements(Statements, Statements).

%
% Notice that order matters: for example ifthenelse should be tested before a bind
%
opinfo("p_number_x",[body,ifthenelse,bind("x","(_number+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_number_y",[body,ifthenelse,bind("y","(_number+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_atomic_x",[body,ifthenelse,bind("x","(_atomic+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_atomic_y",[body,ifthenelse,bind("y","(_atomic+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_primitive_x",[body,ifthenelse,bind("x","(_primitive+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_primitive_y",[body,ifthenelse,bind("y","(_primitive+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_compound_x",[body,ifthenelse,bind("x","(_compound+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_compound_y",[body,ifthenelse,bind("y","(_compound+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_atom_x",[body,ifthenelse,bind("x","(_atom+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_atom_y",[body,ifthenelse,bind("y","(_atom+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_integer_x",[body,ifthenelse,bind("x","(_integer+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_integer_y",[body,ifthenelse,bind("y","(_integer+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_float_x",[body,ifthenelse,bind("x","AbsAppl((CELL *)FunctorDouble)",t_ptr=[])]).
opinfo("p_float_y",[body,ifthenelse,bind("y","AbsAppl((CELL *)FunctorDouble)",t_ptr=[])]).
opinfo("p_db_ref_x",[body,ifthenelse,bind("x","AbsAppl((CELL *)FunctorDBRef)",t_ptr=[])]).
opinfo("p_db_ref_y",[body,ifthenelse,bind("y","AbsAppl((CELL *)FunctorDBRef)",t_ptr=[])]).
opinfo("p_var_x",[body,ifthenelse,bind("x","(_var+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_var_y",[body,ifthenelse,bind("y","(_var+1)*sizeof(CELL)",t_ptr=[])]).
opinfo("p_nonvar_x",[body,ifthenelse]).
opinfo("p_nonvar_y",[body,ifthenelse]).
opinfo("save_b_x",[body,new("x")]).
opinfo("save_b_y",[body,new("y")]).
opinfo("ensure_space",[]).
opinfo("write_x_loc",[body]).
opinfo("write_x_var",[body,new("x")]).
opinfo("write_y_var",[body,new("y")]).
opinfo("write_y_val",[body]).
opinfo("write_y_loc",[body]).
opinfo("get_x_var",[dup("xr","xl")]).
opinfo("get_y_var",[dup("x","y")]).
opinfo("get_yy_var",[dup("x1","y1"),dup("x2","y2")]).
opinfo("put_x_var",[new("xl"),new("xr")]).
opinfo("put_y_var",[new("x"),new("y")]).
opinfo("get_x_val",[unify("xl","xr")]).
opinfo("get_y_val",[unify("x","y")]).
opinfo("put_x_val",[dup("xl","xr")]).
opinfo("put_y_val",[dup("y","x")]).
opinfo("put_unsafe",[dup("y","x")]).
opinfo("put_xx_val",[dup("xl1","xr1"),dup("xl2","xr2")]).
opinfo("glist_valx",[bind("xl","AbsPair(NULL)",workpc=currentop)]).
opinfo("get_atom",[bind("x","c",[])]).
opinfo("get_list",[bind("x","AbsPair(NULL)",workpc=nextop)]).
opinfo("glist_valy",[bind("x","AbsPair(NULL)",workpc=currentop)]).
opinfo("gl_void_valx",[bind("xl","AbsPair(NULL)",workpc=currentop)]).
opinfo("gl_void_valy",[bind("y","AbsPair(NULL)",workpc=currentop)]).
opinfo("gl_void_varx",[bind("xl","AbsPair(NULL)",workpc=currentop),new("xr")]).
opinfo("gl_void_vary",[bind("y","AbsPair(NULL)",workpc=currentop),new("y")]).
opinfo("get_struct",[bind("x","AbsAppl((CELL *)cl->u.xfa.f)",workpc=nextop)]).
opinfo("get_float",[bind("x","AbsAppl((CELL *)FunctorDouble)",t_ptr="d")]).
opinfo("get_longint",[bind("x","AbsAppl((CELL *)FunctorLongInt)",t_ptr="i")]).
opinfo("get_bigint",[bind("x","AbsAppl((CELL *)FunctorBigInt)",t_ptr=[])]).
opinfo("copy_idb_term",[logical]).
opinfo("unify_idb_term",[logical]).
opinfo("put_atom",[new("x")]).
opinfo("put_dbterm",[new("x")]).
opinfo("put_bigint",[new("x")]).
opinfo("put_float",[new("x")]).
opinfo("put_longint",[new("x")]).
opinfo("put_list",[new("x")]).
opinfo("put_struct",[new("x")]).
opinfo("get_2atoms",[bind(1,"c1",[]),
		      bind(2,"c2",[])]).
opinfo("get_3atoms",[bind(1,"c1",[]),
		      bind(2,"c2",[]),
		      bind(3,"c3",[])]).
opinfo("get_4atoms",[bind(1,"c1",[]),
		      bind(2,"c2",[]),
		      bind(3,"c3",[]),
		      bind(4,"c4",[])]).
opinfo("get_5atoms",[bind(1,"c1",[]),
		      bind(2,"c2",[]),
		      bind(3,"c3",[]),
		      bind(4,"c4",[]),
		      bind(5,"c5",[])]).
opinfo("get_6atoms",[bind(1,"c1",[]),
		      bind(2,"c2",[]),
		      bind(3,"c3",[]),
		      bind(4,"c4",[]),
		      bind(5,"c5",[]),
		      bind(6,"c6",[])]).
opinfo("unify_x_var",[new("x")]).
opinfo("unify_x_var_write",[new("x")]).
opinfo("unify_l_x_var",[new("x")]).
opinfo("unify_l_x_var_write",[new("x")]).
opinfo("unify_y_var",[new("y")]).
opinfo("unify_y_var_write",[new("y")]).
opinfo("unify_l_y_var",[new("y")]).
opinfo("unify_l_y_var_write",[new("y")]).
opinfo("save_pair_x_write",[new("x")]).
opinfo("save_pair_x",[new("x")]).
opinfo("save_appl_x_write",[new("x")]).
opinfo("save_appl_x",[new("x")]).
opinfo("save_pair_y_write",[new("y")]).
opinfo("save_pair_y",[new("y")]).
opinfo("save_appl_y_write",[new("y")]).
opinfo("save_appl_y",[new("y")]).
opinfo("unify_x_var2",[new("xl"),new("xr")]).
opinfo("unify_x_var2_write",[new("xl"),new("xr")]).
opinfo("unify_l_x_var2",[new("xl"),new("xr")]).
opinfo("unify_l_x_var2_write",[new("xl"),new("xr")]).
opinfo("p_plus_vv",[body,new("x")]).
opinfo("p_plus_vc",[body,new("x")]).
opinfo("p_minus_vv",[body,new("x")]).
opinfo("p_minus_vc",[body,new("x")]).
opinfo("p_times_vv",[body,new("x")]).
opinfo("p_times_vc",[body,new("x")]).
opinfo("p_div_vv",[body,new("x")]).
opinfo("p_div_vc",[body,new("x")]).
opinfo("p_div_cv",[body,new("x")]).
opinfo("p_and_vv",[body,new("x")]).
opinfo("p_and_vc",[body,new("x")]).
opinfo("p_or_vv",[body,new("x")]).
opinfo("p_or_vc",[body,new("x")]).
opinfo("p_sll_vv",[body,new("x")]).
opinfo("p_sll_vc",[body,new("x")]).
opinfo("p_sll_cv",[body,new("x")]).
opinfo("p_slr_vv",[body,new("x")]).
opinfo("p_slr_vc",[body,new("x")]).
opinfo("p_slr_cv",[body,new("x")]).
opinfo("p_arg_vv",[body,new("x")]).
opinfo("p_arg_cv",[body,new("x")]).
opinfo("p_func2s_vv",[body,new("x")]).
opinfo("p_func2s_vc",[body,new("x")]).
opinfo("p_func2s_cv",[body,new("x")]).
opinfo("p_func2f_vv",[body,new("x")]).
opinfo("p_func2f_xx",[body,new("x")]).
opinfo("p_func2f_xy",[body,new("x")]).
opinfo("p_plus_y_vv",[body,new("y")]).
opinfo("p_plus_y_vc",[body,new("y")]).
opinfo("p_minus_y_vv",[body,new("y")]).
opinfo("p_minus_y_vc",[body,new("y")]).
opinfo("p_times_y_vv",[body,new("y")]).
opinfo("p_times_y_vc",[body,new("y")]).
opinfo("p_div_y_vv",[body,new("y")]).
opinfo("p_div_y_vc",[body,new("y")]).
opinfo("p_div_y_cv",[body,new("y")]).
opinfo("p_and_y_vv",[body,new("y")]).
opinfo("p_and_y_vc",[body,new("y")]).
opinfo("p_or_y_vv",[body,new("y")]).
opinfo("p_or_y_vc",[body,new("y")]).
opinfo("p_sll_y_vv",[body,new("y")]).
opinfo("p_sll_y_vc",[body,new("y")]).
opinfo("p_sll_y_cv",[body,new("y")]).
opinfo("p_slr_y_vv",[body,new("y")]).
opinfo("p_slr_y_vc",[body,new("y")]).
opinfo("p_slr_y_cv",[body,new("y")]).
opinfo("p_arg_y_vv",[body,new("y")]).
opinfo("p_arg_y_cv",[body,new("y")]).
opinfo("p_func2s_y_vv",[body,new("y")]).
opinfo("p_func2s_y_vc",[body,new("y")]).
opinfo("p_func2s_y_cv",[body,new("y")]).
opinfo("p_func2f_yx",[body,new("y")]).
opinfo("p_func2f_yy",[body,new("x")]).
opinfo("put_fi_var_x",[body,new("x")]).
opinfo("put_i_var_x",[body,new("x")]).
opinfo("put_f_var_x",[body,new("x")]).
opinfo("put_fi_var_y",[body,new("y")]).
opinfo("put_i_var_y",[body,new("y")]).
opinfo("put_f_var_y",[body,new("y")]).
opinfo("allocate",[body]).
opinfo("write_void",[body]).
opinfo("write_list",[body]).
opinfo("write_l_list",[body]).
opinfo("enter_a_profiling",[body]).
opinfo("count_a_call",[body]).
opinfo("unify_x_val_write",[]).
opinfo("unify_x_val",[]).
opinfo("unify_l_x_val_write",[]).
opinfo("unify_l_x_val",[]).
opinfo("unify_x_loc_write",[]).
opinfo("unify_x_loc",[]).
opinfo("unify_l_x_loc_write",[]).
opinfo("unify_l_x_loc",[]).
opinfo("unify_y_val_write",[]).
opinfo("unify_y_val",[]).
opinfo("unify_l_y_val_write",[]).
opinfo("unify_l_y_val",[]).
opinfo("unify_y_loc_write",[]).
opinfo("unify_y_loc",[]).
opinfo("unify_l_y_loc_write",[]).
opinfo("unify_l_y_loc",[]).
opinfo("unify_void",[]).
opinfo("unify_void_write",[]).
opinfo("unify_l_void",[]).
opinfo("unify_l_void_write",[]).
opinfo("unify_n_voids",[]).
opinfo("unify_n_voids_write",[]).
opinfo("unify_l_n_voids",[]).
opinfo("unify_l_n_voids_write",[]).
opinfo("write_n_voids",[body]).
opinfo("unify_list",[]).
opinfo("unify_list_write",[]).
opinfo("unify_l_list",[]).
opinfo("unify_l_list_write",[]).
opinfo("unify_atom",[]).
opinfo("unify_atom_write",[]).
opinfo("unify_l_atom",[]).
opinfo("unify_l_atom_write",[]).
opinfo("write_atom",[body]).
opinfo("unify_n_atoms",[]).
opinfo("unify_n_atoms_write",[]).
opinfo("unify_l_n_atoms",[]).
opinfo("unify_l_n_atoms_write",[]).
opinfo("write_n_atoms",[body]).
opinfo("unify_struct",[]).
opinfo("unify_struct_write",[]).
opinfo("unify_l_struc",[]).
opinfo("unify_l_struc_write",[]).
opinfo("write_struc",[body]).
opinfo("write_l_struc",[body]).
opinfo("unify_float",[]).
opinfo("unify_float_write",[]).
opinfo("unify_l_float",[]).
opinfo("unify_l_float_write",[]).
opinfo("write_float",[body]).
opinfo("unify_longint",[]).
opinfo("unify_longint_write",[]).
opinfo("unify_l_longint",[]).
opinfo("unify_l_longint_write",[]).
opinfo("write_longint",[body]).
opinfo("unify_bigint",[]).
opinfo("unify_bigint_write",[]).
opinfo("unify_l_bigint",[]).
opinfo("unify_l_bigint_write",[]).
opinfo("write_bigint",[body]).
opinfo("unify_dbterm",[]).
opinfo("unify_dbterm_write",[]).
opinfo("unify_l_dbterm",[]).
opinfo("unify_l_dbterm_write",[]).
opinfo("write_dbterm",[body]).
opinfo("pop",[]).
opinfo("pop_n",[]).
opinfo("eqc_float",[body]).
opinfo("ltc_float",[body]).
opinfo("gtc_float",[body]).
opinfo("eqc_int",[body]).
opinfo("ltc_int",[body]).
opinfo("gtc_int",[body]).
opinfo("a_eq",[body]).
opinfo("lt",[body]).
opinfo("add_float_c",[body]).
opinfo("sub_float_c",[body]).
opinfo("mul_float_c",[body]).
opinfo("fdiv_c1",[body]).
opinfo("fdiv_c2",[body]).
opinfo("add_int_c",[body]).
opinfo("sub_int_c",[body]).
opinfo("mul_int_c",[body]).
opinfo("idiv_c1",[body]).
opinfo("idiv_c2",[body]).
opinfo("mod_c1",[body]).
opinfo("mod_c2",[body]).
opinfo("rem_c1",[body]).
opinfo("rem_c2",[body]).
opinfo("a_or_c",[body]).
opinfo("a_and_c",[body]).
opinfo("xopr_c",[body]).
opinfo("sl_c1",[body]).
opinfo("sl_c2",[body]).
opinfo("sr_c1",[body]).
opinfo("sr_c2",[body]).
opinfo("add",[body]).
opinfo("sub",[body]).
opinfo("mul",[body]).
opinfo("fdiv",[body]).
opinfo("idiv",[body]).
opinfo("mod",[body]).
opinfo("rem",[body]).
opinfo("a_or",[body]).
opinfo("a_and",[body]).
opinfo("xor",[body]).
opinfo("uminus",[body]).
opinfo("sl",[body]).
opinfo("sr",[body]).
opinfo("get_fi_x",[body]).
opinfo("get_i_x",[body]).
opinfo("get_f_x",[body]).
opinfo("get_fi_y",[body]).
opinfo("get_i_y",[body]).
opinfo("get_f_y",[body]).
opinfo("put_fi_val_x",[body]).
opinfo("put_f_val_x",[body]).
opinfo("put_i_val_x",[body]).
opinfo("put_fi_val_y",[body]).
opinfo("put_f_val_y",[body]).
opinfo("put_i_val_y",[body]).
opinfo("lock_lu",[body]).
opinfo("call_bfunc_xx",[body]).
opinfo("call_bfunc_yx",[body]).
opinfo("call_bfunc_xy",[body]).
opinfo("call_bfunc_yy",[body]).
opinfo("run_eam",[body]).
opinfo("retry_eam",[body]).
opinfo("alloc_for_logical_pred",[body]).
opinfo("deallocate",[body]).
opinfo("table_try_single",[]).
opinfo("native_me",[]).

output_save_clause(S) :-
	setof(T,O^op(T,O),Types),
	member(T, Types),
	output_save_type(S, T),
	fail.
output_save_clause(_).

output_save_type(S, T) :-
	format(S,'      /* instructions type ~s */~n',[T]),
	setof(Op,op(T,Op),Ops),
	dump_ops(S,Ops),
	% then the code for every instruction with this header.
	tinfo(T, Desc),
	output_save(S, T, Desc, T),
	format(S,'      pc = NEXTOP(pc,~s);~n',[T]),
	format(S,'      break;~n',[]).

output_save(S, "e", [], _) :-
	format(S, "      if (op == _Nstop || op == _copy_idb_term || op == _unify_idb_term) return 1;~n", []).
output_save(_, [], [], _).
output_save(S, [Name|Names], [Type|Types], Desc) :-
	output_save_type(S, Name, Type, Desc),
	output_save(S, Names, Types, Desc).

output_save_type(S, OpT, T-"none", Desc) :- !,
	get_op(OpT, Name),
	format(S, "      CHECK(save_~s(stream, pc->u.~s.~s));~n", [Name, Desc, T]).
output_save_type(S, OpT, T-Def, Desc) :-
	get_op(OpT, Name),
	format(S, "#ifdef ~s~n      CHECK(save_~s(stream, pc->u.~s.~s));~n#endif~n", [Def,Name, Desc, T]).