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

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


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

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

/* 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);
}
',[]).

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