/*-------------------------------------------------------------------------*/
/* Passe 4: Generation du code. */
/* */
/* predicat d'appel: generation_code(T,C,NbChunk,Pred,W) */
/* */
/* entree */
/* T : format interne de la tete */
/* C : format interne du corps */
/* NbChunk: nombre de chunks du corps */
/* */
/* sortie */
/* Pred : nom du predicat de la tete (nom de la clause) */
/* W : code wam associe a la clause, W = [inst_wam,...] */
/* */
/* */
/* Principe: */
/* genere_tete se charge de generer le code de la tete. */
/* genere_corps se charge de generer le code du corps. Remarquer que si le */
/* dernier but est un predicat inline il n'y a pas de execute mais un */
/* un proceed. */
/* */
/* Les termes structures: */
/* On entend par terme structure un format interne lst(_,_) ou stc(_,_), */
/* on designera pas Strc de tels formats. */
/* La gestion des termes structures de la tete et du corps est assuree par */
/* gen_lst_strc(LStrcReg,UL,LSuiv,W) */
/* */
/* entree */
/* LStrcReg: une liste de Strc/Reg dont il faut generer le code */
/* UL : unif/load pour differencier les traitements */
/* LSuiv : liste de codes wam a placer apres le resultat */
/* */
/* sortie */
/* W : code wam associe a LStrcReg */
/* */
/* Un element de LStrcReg (un Strc/Reg) indique que Strc doit etre unifie */
/* avec (resp. charge dans) le registre Reg si UL=unif (resp. UL=load). */
/* */
/* Pour chaque Strc/Reg on appelle: */
/* */
/* gen_strc(Strc,Reg,UL,LSuiv,StrcW,LStrcRegAux) qui calcule le code wam */
/* associe a Strc/Reg (StrcW) et fournit une liste auxiliaire contenant */
/* les sous termes structures de Strc (liste LStrcRegAux). */
/* */
/* Il reste alors a rappeler gen_lst_strc() sur LStrcRegAux et aussi sur */
/* LStrcReg' (LStrcReg = [Strc/Reg | LStrcReg']). */
/* Ce qui differe entre la tete et le corps est la facon dont doivent etre */
/* ajances les differents codes: */
/* */
/* en unif (tete) : LStrcRegW = StrcW + LStrcRegAuxW + LStrcReg'W */
/* en load (corps): LStrcRegW = LStrcRegAuxW + StrcW + LStrcReg'W */
/* */
/* Exemples: */
/* */
/* p(f(g(a,b),c)). */
/* */
/* LStrcReg = [f(g(a,b),c)/0] (0 car a unifier contre A0) */
/* StrcW = [get_structure(f/2,0), */
/* unify_x_variable(_1), */
/* unify_constant(c)] */
/* */
/* LStrcRegAux = [g(a,b)/_1] (_1 temporaire cree) */
/* */
/* puis: */
/* LStrcRegAuxW= [get_structure(g/2,_1), */
/* unify_constant(a), */
/* unify_constant(b)] */
/* */
/* d'ou: */
/* LStrcRegW = [get_structure(f/2,0), */
/* unify_x_variable(_1), */
/* unify_constant(c), */
/* get_structure(g/2,_1), */
/* unify_constant(a), */
/* unify_constant(b)] */
/* */
/* */
/* p:- q(f(g(a,b),c)). */
/* */
/* LStrcReg = [f(g(a,b),c)/0] (0 car a charger dans A0) */
/* StrcW = [put_structure(f/2,0), */
/* unify_x_value(_1), */
/* unify_constant(c)] */
/* */
/* LStrcRegAux = [g(a,b)/_1] (_1 temporaire cree) */
/* */
/* puis: */
/* LStrcRegAuxW= [put_structure(g/2,_1), */
/* unify_constant(a), */
/* unify_constant(b)] */
/* */
/* d'ou: */
/* LStrcRegW = [put_structure(g/2,_1), */
/* unify_constant(a), */
/* unify_constant(b)] */
/* put_structure(f/2,0), */
/* unify_x_value(_1), */
/* unify_constant(c)] */
/*-------------------------------------------------------------------------*/
:- public generation_code/5.
generation_code(T,C,NbChunk,Pred,TW1):-
g_assign(nb_chunk,NbChunk),
g_read(debug,Debug),
(Debug>0 -> TW1=[dbg_clause|TW], CW1=[dbg_body|CW]
; TW1=TW, CW1=CW),
genere_tete(T,NbChunk,CW1,TW,Pred),
genere_corps(C,CW).
genere_tete(p(_,Pred,LstArg,NbY),NbChunk,LSuiv,TW,Pred):-
gen_tete_lst_arg(LstArg,0,LSuiv,TW1),
(NbChunk > 1 -> TW=[allocate(NbY)|TW1]
; TW=TW1).
gen_tete_lst_arg([],_,LSuiv,LSuiv).
gen_tete_lst_arg([Arg|LstArg],Reg,LSuiv,ArgW):-
gen_unif_arg(Arg,Reg,LstArgW,ArgW),
!,
Reg1 is Reg+1,
gen_tete_lst_arg(LstArg,Reg1,LSuiv,LstArgW).
genere_corps([],[proceed]). % 0 buts
genere_corps([p(_,fail/0,[],_)|_],[fail]).
genere_corps([p(_,false/0,[],_)|_],[fail]).
genere_corps([p(NoPred,Pred/N,LstArg,_)|C],PredW):-
inline_predicate(Pred,N),
gen_inline_pred(Pred,N,NoPred,LstArg,CW,PredW),
(C=[] -> (NoPred>1 -> CW=[deallocate,proceed]
; CW=[proceed])
;
genere_corps(C,CW)).
genere_corps([p(NoPred,Pred,LstArg,_)|C],PredW):-
gen_corps_lst_arg(LstArg,0,NoPred,CallExecuteW,PredW),
(C=[] -> (NoPred>1 -> CallExecuteW=[deallocate,execute(Pred)]
; CallExecuteW=[execute(Pred)])
;
CallExecuteW=[call(Pred)|CW],
genere_corps(C,CW)).
gen_corps_lst_arg([],_,_,LSuiv,LSuiv).
gen_corps_lst_arg([Arg|LstArg],Reg,NoPred,LSuiv,ArgW):-
gen_load_arg(Arg,Reg,NoPred,LstArgW,ArgW),
Reg1 is Reg+1,
!,
gen_corps_lst_arg(LstArg,Reg1,NoPred,LSuiv,LstArgW).
/* gen_unif_arg(Arg,Reg,LSuiv,W) */
gen_unif_arg(var(igv(x(No),_,_,_,_),PremOcc,_),Reg,LSuiv,[ArgW|LSuiv]):-
(PremOcc==t -> ArgW=get_x_variable(No,Reg)
; ArgW=get_x_value(No,Reg)).
gen_unif_arg(var(igv(y(No),_,_,_,_),PremOcc,_),Reg,LSuiv,[ArgW|LSuiv]):-
(PremOcc==t -> ArgW=get_y_variable(No,Reg)
; ArgW=get_y_value(No,Reg)).
gen_unif_arg(cst(C),Reg,LSuiv,[get_constant(C,Reg)|LSuiv]).
gen_unif_arg(int(N),Reg,LSuiv,[get_integer(N,Reg)|LSuiv]).
gen_unif_arg(nil,Reg,LSuiv,[get_nil(Reg)|LSuiv]).
gen_unif_arg(Strc,Reg,LSuiv,StrcW):-
gen_lst_strc([Strc/Reg],unif,LSuiv,StrcW).
/* gen_load_arg(Arg,Reg,NoPred,LSuiv,W) */
gen_load_arg(var(igv(x(No),_,_,_,_),PremOcc,_),Reg,_,LSuiv,[ArgW|LSuiv]):-
(PremOcc==t -> ArgW=put_x_variable(No,Reg)
; ArgW=put_x_value(No,Reg)).
gen_load_arg(var(igv(y(No),_,_,_,Unsafe),PremOcc,_),Reg,NoPred,LSuiv,[ArgW|LSuiv]):-
(PremOcc==t -> ArgW=put_y_variable(No,Reg)
; (Unsafe==t, g_read(nb_chunk,NoPred)
-> ArgW=put_y_unsafe_value(No,Reg)
; ArgW=put_y_value(No,Reg))).
gen_load_arg(cst(C),Reg,_,LSuiv,[put_constant(C,Reg)|LSuiv]).
gen_load_arg(int(N),Reg,_,LSuiv,[put_integer(N,Reg)|LSuiv]).
gen_load_arg(nil,Reg,_,LSuiv,[put_nil(Reg)|LSuiv]).
gen_load_arg(Strc,Reg,_,LSuiv,StrcW):-
gen_lst_strc([Strc/Reg],load,LSuiv,StrcW).
/* gen_lst_strc(LStrcReg,UL,LSuiv,W) */
gen_lst_strc([],_,LSuiv,LSuiv).
gen_lst_strc([Strc/Reg|LStrcReg],UL,LSuiv,W):-
gen_strc(Strc,Reg,UL,W1,W2,LStrcRegAux),
gen_lst_strc(LStrcRegAux,UL,W3,W4),
gen_lst_strc(LStrcReg,UL,LSuiv,W5),
(UL==unif -> W=W2, W1=W4, W3=W5
; W=W4, W3=W2, W1=W5).
gen_strc(lst(Car,Cdr),Reg,UL,LSuiv,[W|LstW],LStrcRegAux):-
(UL==unif -> W=get_list(Reg)
; W=put_list(Reg)),
gen_unify_lst_arg([Car,Cdr],UL,LSuiv,LstW,LStrcRegAux).
gen_strc(stc(F,LstArg),Reg,UL,LSuiv,[W|StcW],LStrcRegAux):-
(UL==unif -> W=get_structure(F,Reg)
; W=put_structure(F,Reg)),
gen_unify_lst_arg(LstArg,UL,LSuiv,StcW,LStrcRegAux).
gen_unify_lst_arg([],_,LSuiv,LSuiv,[]).
gen_unify_lst_arg([Arg|LstArg],UL,LSuiv,ArgW,LStrcRegAux1):-
gen_compte_void([Arg|LstArg],0,N,LstArg1),
(N=0
-> gen_unify_arg(Arg,UL,LstArgW,ArgW,LStrcRegAux,LStrcRegAux1),
gen_unify_lst_arg(LstArg,UL,LSuiv,LstArgW,LStrcRegAux)
;
ArgW=[unify_void(N)|LstArg1W],
gen_unify_lst_arg(LstArg1,UL,LSuiv,LstArg1W,LStrcRegAux1)),
!.
gen_compte_void([var(_,t,t)|LstArg],N,N2,LstArg1):-
N1 is N+1,
gen_compte_void(LstArg,N1,N2,LstArg1).
gen_compte_void(LstArg,N,N,LstArg).
gen_unify_arg(var(igv(x(No),NoPPOcc,_,Stc,_),PremOcc,_),_,LSuiv,[ArgW|LSuiv],
LStrcRegAux,LStrcRegAux):-
(PremOcc==t -> ArgW=unify_x_variable(No)
; (NoPPOcc=0, Stc==f -> ArgW=unify_x_local_value(No)
; ArgW=unify_x_value(No))).
gen_unify_arg(var(igv(y(No),_,_,Stc,_),PremOcc,_),_,LSuiv,[ArgW|LSuiv],
LStrcRegAux,LStrcRegAux):-
(PremOcc==t -> ArgW=unify_y_variable(No)
; (Stc==f -> ArgW=unify_y_local_value(No)
; ArgW=unify_y_value(No))).
gen_unify_arg(cst(C),_,LSuiv,[unify_constant(C)|LSuiv],LStrcRegAux,LStrcRegAux).
gen_unify_arg(int(N),_,LSuiv,[unify_integer(N)|LSuiv],LStrcRegAux,LStrcRegAux).
gen_unify_arg(nil,_,LSuiv,[unify_nil|LSuiv],LStrcRegAux,LStrcRegAux).
gen_unify_arg(Strc,UL,LSuiv,[ArgW|LSuiv],LStrcRegAux,[Strc/Reg|LStrcRegAux]):-
(UL==unif -> ArgW=unify_x_variable(Reg)
; ArgW=unify_x_value(Reg)).
% Code des predicats inline :
% gen_inline_pred(Pred,Arite,NoPred,LstArg,LSuiv,Code)
% Tous les predicats definis ici doivent aussi avoir une clause
% dans le predicat inline_predicate/3 en passe 2 definissant tous
% les predicats inline.
/* Cut inline ('$get_bc_reg'/1,'$cut'/1) */
gen_inline_pred('$get_bc_reg',1,_,[var(igv(Nom,_,_,_,_),PremOcc,_)],
LSuiv,[InstW|LSuiv]):-
(PremOcc==f -> error('$get_bc_reg used with bound variable...')
; true),
(Nom=x(No), InstW=get_x_bc_reg(No)
;
Nom=y(No), InstW=get_y_bc_reg(No)).
gen_inline_pred('$cut',1,_,[var(igv(Nom,_,_,_,_),_,_)],LSuiv,[InstW|LSuiv]):-
(Nom=x(No), InstW=cut_x(No)
;
Nom=y(No), InstW=cut_y(No)).
/* dbg_true */
gen_inline_pred('$dbg_true',0,_,_,LSuiv,LSuiv).
/* Pragma C (pragma_c/1) */
gen_inline_pred(pragma_c,1,_,[cst(Code)],LSuiv,[pragma_c(Code)|LSuiv]).
/* calling module nb inline */
gen_inline_pred(calling_module_nb,1,NoPred,[Arg1],LSuiv,CodeW):-
gen_inline_pred((=),2,NoPred,[Arg1,int('CMN')],LSuiv,CodeW).
/* Unification inline (=/2) */
gen_inline_pred((=),2,NoPred,[Arg1,Arg2],LSuiv,UnifW):-
(Arg1=var(igv(x(Reg),_,_,_,_),PremOcc,_)
-> inline_unif_reg_terme(PremOcc,Reg,Arg2,NoPred,LSuiv,UnifW)
;
(Arg2=var(igv(x(Reg),_,_,_,_),PremOcc,_)
-> inline_unif_reg_terme(PremOcc,Reg,Arg1,NoPred,
LSuiv,UnifW)
;
gen_load_arg(Arg1,Reg,NoPred,Unif1W,UnifW),
inline_unif_reg_terme(PremOcc,Reg,Arg2,NoPred,
LSuiv,Unif1W))).
inline_unif_reg_terme(f,Reg,Arg,_,LSuiv,UnifW):-
gen_unif_arg(Arg,Reg,LSuiv,UnifW).
inline_unif_reg_terme(_,Reg,Arg,NoPred,LSuiv,UnifW):-
gen_load_arg(Arg,Reg,NoPred,LSuiv,UnifW).
/* Type test inline */
gen_inline_pred(F,1,_,[Arg],LSuiv,TestW):-
type_test_functor(F),
gen_load_arg(Arg,Reg,_,InstW,TestW),
InstW=[builtin_1(F,Reg)|LSuiv].
type_test_functor(var).
type_test_functor(nonvar).
type_test_functor(atom).
type_test_functor(integer).
type_test_functor(number).
type_test_functor(atomic).
type_test_functor(compound).
type_test_functor(callable).
/* Term decomposition + compare/3 inline */
gen_inline_pred(F,3,_,[Arg1,Arg2,Arg3],LSuiv,TermW):-
term_ope_functor(F),
gen_load_arg(Arg1,Reg1,_,Term1W,TermW),
gen_load_arg(Arg2,Reg2,_,Term2W,Term1W),
gen_load_arg(Arg3,Reg3,_,InstW,Term2W),
InstW=[builtin_3(F,Reg1,Reg2,Reg3)|LSuiv].
term_ope_functor(arg).
term_ope_functor(functor).
term_ope_functor(compare).
/* Term comparison inline */
gen_inline_pred(F,2,_,[Arg1,Arg2],LSuiv,CompW):-
term_cmp_functor_name(F,Name),
gen_load_arg(Arg1,Reg1,_,Comp1W,CompW),
gen_load_arg(Arg2,Reg2,_,InstW,Comp1W),
!,
InstW=[builtin_2(Name,Reg1,Reg2)|LSuiv].
term_cmp_functor_name((=..),term_univ). % not a cmp but its arity is 2
term_cmp_functor_name((==), term_eq).
term_cmp_functor_name((\==),term_neq).
term_cmp_functor_name((@<), term_lt).
term_cmp_functor_name((@=<),term_lte).
term_cmp_functor_name((@>), term_gt).
term_cmp_functor_name((@>=),term_gte).
/* Mathematical inlines (is/2 =:=/2 ...) */
gen_inline_pred(is,2,_,[Arg1,Arg2],LSuiv,MathW):-
inline_load_math_expr(Arg2,Reg,UnifW,MathW),
!,
gen_unif_arg(Arg1,Reg,LSuiv,UnifW).
gen_inline_pred(F,2,_,[Arg1,Arg2],LSuiv,Math1W):-
math_cmp_functor_name(F,Name),
inline_load_math_expr(Arg1,Reg1,Math2W,Math1W),
inline_load_math_expr(Arg2,Reg2,InstW, Math2W),
!,
InstW=[builtin_2(Name,Reg1,Reg2)|LSuiv].
inline_load_math_expr(var(igv(Nom,_,_,_,_),PremOcc,_),Reg,LSuiv,MathW):-
(PremOcc==t
-> error('Illegal arithmetic expression - free variable')
; (Nom=x(No), MathW=[math_load_x_value(No,Reg)|LSuiv]
;
Nom=y(No), MathW=[math_load_y_value(No,Reg)|LSuiv])).
inline_load_math_expr(int(N),Reg,LSuiv,MathW):-
MathW=[put_integer(N,Reg)|LSuiv].
inline_load_math_expr(lst(Arg,nil),Reg,LSuiv,MathW):-
inline_load_math_expr(Arg,Reg,LSuiv,MathW).
inline_load_math_expr(stc(F/_,[Arg]),Reg,LSuiv,MathW):-
(F== (-) -> Name=neg
; math_exp_functor_name(F,Name)),
inline_load_math_expr(Arg,Reg1,InstW,MathW),
(Name==add -> Reg=Reg1,
InstW=LSuiv
;
InstW=[function_1(Name,Reg,Reg1)|LSuiv]).
inline_load_math_expr(stc(F/_,[Arg1,Arg2]),Reg,LSuiv,MathW):-
math_exp_functor_name(F,Name),
inline_load_math_expr(Arg1,Reg1,Math1W,MathW),
(Arg2=int(1), (Name==add, Name1=inc ; Name==sub, Name1=dec)
-> Math1W=InstW,
InstW=[function_1(Name1,Reg,Reg1)|LSuiv]
;
inline_load_math_expr(Arg2,Reg2,InstW,Math1W),
InstW=[function_2(Name,Reg,Reg1,Reg2)|LSuiv]).
inline_load_math_expr(X,_,_,_):-
error('Illegal arithmetic expression - unknown operation'(X)).
math_exp_functor_name((+), add).
math_exp_functor_name((-), sub).
math_exp_functor_name((*), mul).
math_exp_functor_name((//), div).
math_exp_functor_name(mod, mod).
math_exp_functor_name((/\), and).
math_exp_functor_name((\/), or).
math_exp_functor_name((^), xor).
math_exp_functor_name((\), not).
math_exp_functor_name((<<), shl).
math_exp_functor_name((>>), shr).
math_cmp_functor_name((=:=),eq).
math_cmp_functor_name((=\=),neq).
math_cmp_functor_name((<), lt).
math_cmp_functor_name((=<), lte).
math_cmp_functor_name((>), gt).
math_cmp_functor_name((>=), gte).
/* Global variables */
gen_inline_pred(F,2,_,[Arg1,Arg2],LSuiv,GVarW):-
g_var_functor(F),
gen_load_arg(Arg1,Reg1,_,GVar1W,GVarW),
gen_load_arg(Arg2,Reg2,_,InstW,GVar1W),
InstW=[builtin_2(F,Reg1,Reg2)|LSuiv].
g_var_functor(g_assign).
g_var_functor(g_assignb).
g_var_functor(g_link).
g_var_functor(g_read).
g_var_functor(g_array_size).
syntax highlighted by Code2HTML, v. 0.9.1