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(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),
	header(W),
	header_rclause(C),
	header_walk_clause(L),
	file('C/absmi.c', W, C, L),
	start_ifdef("YAPOR", W, C, L),
	file('OPTYap/or.insts.i',W, C, L),
	end_ifdef(W,C,L),
	start_ifdef("TABLING",W,C,L),
	file('OPTYap/tab.insts.i',W,C,L),
	retractall(op(_,_)),
	file('OPTYap/tab.tries.insts.i',W,C,L),
	end_ifdef(W,C,L),
	footer(W),
	footer_rclause(C),
	footer_walk_clause(L),
	close(L),
	close(W),
	close(C).

start_ifdef(D,W,C,L) :-
	retractall(op(_,_)),
	format(W, '#ifdef ~s~n',[D]),
	format(C, '#ifdef ~s~n',[D]),
	format(L, '#ifdef ~s~n',[D]).
	
end_ifdef(W,C,L) :-
	format(W, '#endif~n',[]),
	format(C, '#endif~n',[]),
	format(L, '#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)
{
  do {
    op_numbers 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) {
',[]).


file(I,W,C,L) :-
	open(I,read,R),
	process(R,grep_opcode(W)),
	close(R),
	output_rclause(C),
	output_walk_clause(L).

grep_opcode(W, 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("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]).

% 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(_,_).

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'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'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]) :-
	special(Op,C),
	format(C,'    case _~s:~n',[Op]),
	end_special(Op,C),
	dump_ops(C,Ops).

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 = [_|_],
	dump_ops(C,Ops),
	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],Ops1,[Op|Ops2]) :-
	split_ops(Ops0,Ops1,Ops2).

split_ops1("e", 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").

% I field gives direct access to LU index block and to all Pred information
output_walk(C,"Ills",_) :- !,
	format(C,'      return walk_got_lu_block(pc->u.Ills.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',[]).
% ops which point at the clause's predicate.
output_walk(C,"Osblp",_) :- !,
	label_in_clause(C,"Osblp","p0").
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",_) :- !,
	label_in_clause(C,"pp","p0").
output_walk(C,"OtapFs",_) :- !,
	label_in_clause(C,"OtapFs","p").
output_walk(C,"Otapl",_) :- !,
	label_in_clause(C,"Otapl","p").
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);~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);~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);~n',[]),
	output_ewalks(C,Ops).
output_ewalks(C,["spy_pred"|Ops]) :-
	format(C,'      return found_owner_op(pc, startp, endp);~n',[]),
	output_ewalks(C,Ops).
output_ewalks(C,["index_pred"|Ops]) :-
	format(C,'      return found_owner_op(pc, startp, endp);~n',[]),
	output_ewalks(C,Ops).
output_ewalks(C,["lock_pred"|Ops]) :-
	format(C,'      return found_owner_op(pc, startp, endp);~n',[]),
	output_ewalks(C,Ops).
output_ewalks(C,["op_fail"|Ops]) :-
	format(C,'      if (codeptr == FAILCODE)
        return found_fail(pc, startp, endp);~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);~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]).

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',[]).

	/* 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","p"),
	format(W,'#else~n',[]),
	add_pp(W,"p","p"),
	format(W,'#endif~n',[]),
	format(W,'    }
  }
',[]).

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