/* *****************************************************************
*								   *
*	SB-Prolog						   *
*	Copyright SUNY at Stony Brook, 1986			   *
*								   *
****************************************************************** */

/*-----------------------------------------------------------------
SB-Prolog is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY.  No author or distributor
accepts responsibility to anyone for the consequences of using it
or for whether it serves any particular purpose or works at all,
unless he says so in writing.  Refer to the SB-Prolog General Public
License for full details.

Everyone is granted permission to copy, modify and redistribute
SB-Prolog, but only under the conditions described in the
SB-Prolog General Public License.   A copy of this license is
supposed to have been given to you along with SB-Prolog so you
can know your rights and responsibilities.  It should be in a
file named COPYING.  Among other things, the copyright notice
and this notice must be preserved on all copies. 
------------------------------------------------------------------ */


/* begin tprog1.P *************************************************/
/* This program is the beginning of an attempt to write a translator that
will take a preprocessed prolog program and produce a list of PIL
instructions that implements the program.  The preprocessor adds pragma
information to the program to make it possible for it to be processed.  We
use the following representation: 

  preddef(Name,Arity,Clauses,Pragma,Exrefs)
    where
	Name is the predicate name.
	Arity is the arity of the predicate.
	Clauses is a list of clause terms that represent the defining rules.
	Pragma is a list, empty for the moment.
	Exrefs is a list (with tail a var) of external references: 
	  er(Predname,Ep) where Ep is the entry point addr of predicate
	  Predname.

  clause(Args,Clause,Pragma)
    where
	Args is a list of the formal parameters in the head of the clause.
	  (Arity long).
	Clause is a term representing the literals on the rhs of the rule.
	Pragma is a list; s(_,_) is a symbol table with information
	  concerning the variables that appear in the clause. 
	  all(y) indicates alloc-dealloc is necessary, all(n) indicates 
	  it's not nec.

A clause is represented as a term with structure symbols
and(Firstconjunct,Pragma,Secondconjunct),
or(Firstdisjunct,Pragma,Seconddisjunct), not(Negformula,Pragma), or nil if
it is empty.  Goals on the right hand side are represented as:

'_call'(Predname,Arglist,Pragma):
    where
	Predname is the predicate name.
	Arglist is the list of arguments.
	Pragma is the pragma; nv(N) means that N is the size of the 
	  activation record at this point.

For example p(a,b) is represented as '_call'(p,[[a],[b]],[nv(1)]).
Structure and constants are represented as lists, not as normal structures.
Thus f(a,b) would be represented as [f,[a],[b]].  Constants are represented
as 0-ary structures, i.e., lists of length one.  Variables are represented
using v(Vid,Pragma), where Vid is a constant symbol representing the name,
and Pragma is a list.  In the pragma, d(L) indicates that L is the location
in the AR of this variable (or its register if it is a temporary) ; occ(f)
indicates that this is the first occurrence and occ(s) a subsequent
occurrence; k(t) indicates it is a temporary variable, k(p) indicates a
permanent variable, k(u) indicates an unsafe occurrence of a permanent
variable.  k(vh) indicates a void (anonymous) variable occurring at the top
level in the head of a clause, k(vb) indicates a void variable occurring at
the top level in the body of a clause.  */

/* For the clauses:
	p(X,a) :- r(Y,X),s(Y,f(g(g(X)),f(Y,b))).
	p(B,c).
	p(f(a,g(X)),f(g(a),X)).

The query is:

tpred(preddef(p,
	   2,
	   [clause([v(x,[k(p),d(2),occ(f)]),[a]],
		   and('_call'(r,
			    [v(y,[k(p),d(3),occ(f)]),
			     v(x,[k(p),d(2),occ(s)])],
			    [nv(2)]),
		       [],
		       '_call'(s,
			    [v(y,[k(u),d(3),occ(s)]),
			     [f,[g,[g,v(x,[k(p),d(2),occ(s)])]],
				[f,v(y,[k(p),d(3),occ(s)]),[b]]]],
			    [nv(2)])
		      ),
		   [all(y)]),
	    clause([v(b,[k(t),d(1),occ(f)]),[c]],nil,[nv(0),all(n)]),
	    clause([[f,[a],[g,v(x,[k(t),d(3),occ(f)])]],
		    [f,[g,[a]],v(x,[k(t),d(3),occ(s)])]],
		   nil,
		   [all(n)])
	   ],
	   []),
      Label,
      Pil,[],Exref).

*/

/* ----------------------------------------------------------------------

   change to pragma representation for variables : for greater efficiency,
   the Pragma information for variables is being represented as a term,
   "vrec(Type,Occ,Loc,Misc)" where Type is the type of the variable (k(T)
   in old representation), Occ indicates whether this is a first or
   subsequent occurrence (occ(Occ) of older representation), Loc gives the
   location of the variable (d(Loc) in old representation), and Misc stores
   other information as a list.

   - saumya debray, july 8 1985
   ---------------------------------------------------------------------- */

/* **********************************************************************
$tprog1_export([$tprog/3]).

$tprog1_use($index1,[$index/7]).
$tprog1_use($blist,[$append/3,_,$member1/2]).
$tprog1_use($meta,[_,_,$length/2]).
$tprog1_use($computil1,[$reserve/3,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_]).
$tprog1_use($inline1,[$inline/2]).
$tprog1_use($geninline1,[$geninline/7]).
$tprog1_use($tgoal1,[_,$tpar/8,$tgoalargs/7]).
$tprog1_use($glob,[_,$gennum/1,_]).
$tprog1_use($aux1,[_,_,_,_,_,_,$disj_targ_label/2,_,_]).
$tprog1_use($tcond1,[$tcond/7,$cond_branch/8]).
$tprog1_use($listutil1,[_,$merge/3,_,_,_,_,_,_]).
$tprog1_use($disjunc1,[$disj_branch/8,$optimize_CP/2]).
********************************************************************** */


/* $tprog(Progdef,Pil,Pilr) is true if the translation of the Progdef (a
list of Predicates) is the difference list Pil-Pilr.			*/

$tprog([],Pil,Pil,_).
$tprog([Preddef|Prog],Pil,Pilr,Prag) :-
    $tpred(Preddef,Pil,Pilr1,Prag),
    $tprog(Prog,Pilr1,Pilr,Prag).

/* $tpred(Preddef,Label,Pil,Pilr) is true if the translation of Preddef
is the difference list Pil-Pilr, with entry point Label. $tpred loops
through the clauses.  */

$tpred(preddef(Pname,Arity,[Oneclause],P),Pil,Pilr,_) :- !,
    $tclause(Oneclause,P,Pil,Pilr).
$tpred(preddef(Pname,Arity,CList,P),Pil,Pilr,Prag) :- 
	$index(Pname,Arity,CList,P,Pil,Pil0,Prag),
	$length(CList,N),
	((N =< 3, not($member2(trace,Prag)), $tail_rec(CList,Pname,Arity)) ->
		$get_indexinst(Pil,IndList) ;
		IndList = []
	),
	$tclauses(CList,P,Pil1,Pilr),
	(IndList = [switchonterm(_,_,_)|_] ->
		$subst_exec(Pil1,Pname,Arity,IndList,Pil0,Pilr) ;
		Pil1 = Pil0
	).


/* $tclauses generates retry and trust instructions for each clause */

$tclauses([],_,Pil,Pil).
$tclauses([Clause|Restclauses],PredPrag,Pil,Pilr) :- 
    $tclause(Clause,PredPrag,Pil,Pil1),
    $tclauses(Restclauses,PredPrag,Pil1,Pilr).


/* $tclause(Clause,Pil,Piltail) is true if Pil-Piltail is the code that
translates clause Clause. */

$tclause(clause(Args,Body,Prag),PredPrag,[label(L),allocate|Pil],Pilr) :- 
    $member1(all(y),Prag),
    $member1(label(L),Prag),
    $length(Args,N),
    $reserve(N, [], Tin), !,
    $theadpars(1,PredPrag,Args,Pil,Pilr1,Tin,TRegs1),
    $tbody(Body,y,Pilr1,Pilr,TRegs1,_,_,0,[]).
$tclause(clause(Args,Body,Prag),PredPrag,[label(L)|Pil],Pilr) :- 
    $member1(all(n),Prag),
    $member1(label(L),Prag),
    $length(Args,N),
    $reserve(N, [], Tin), !,
    $theadpars(1,PredPrag,Args,Pil,Pilr1,Tin,TRegs1),
    $tbody(Body,n,Pilr1,Pilr,TRegs1,_,_,0,[]).


/* $theadpars loops through the formal parameter list */

$theadpars(_,_,[],Pil,Pil,T,T).

/* TRin = list of temp registers in use at entry; TRout = list of temps
   in use at exit.							*/

$theadpars(N,PredPrag,[Par|Rest],Pil,Pilr,TRin,TRout) :-
    $tpar(h,Par,N,Pil,Pil1,TRin,TRmid,PredPrag),
    N1 is N+1,
    $theadpars(N1,PredPrag,Rest,Pil1,Pilr,TRmid,TRout).

$tbody(nil,_,[proceed|Pil],Pil,T,T,_,_,_) :- !.
$tbody('_call'(Pred,Args,CPrag),A,Pil,Pilr,Tin,Tout,OM,OD,HoldRegs) :-	
	$tbodycall(Args,A,Pil,Pilr,Tin,Tout,OM,OD,HoldRegs,Pred,CPrag).

/* ----------- EFFICIENT CODE FOR DISJUNCTIONS/CONDITIONALS ---------- */
/* 
    This is an algorithm to generate efficient code for disjunctions and
    conditionals nested arbitrarily deep.  The emphasis here is to
    avoid chains of branches when different execution paths come together.
    However, instead of tedious scanning of assembly code to detect this,
    we try to avoid it altogether by passing labels around.

   The idea is the following: execution branches need come together only
   if the goals are of the form (c1 OR c2) AND c3.  In this case, when we
   see the AND, we generate a label, which is the label of the place where
   the execution paths should meet.  This is then passed into the routines
   that process the disjunction, as a parameter "meet(Label)".

   The decision on when to actually emit the "meet" label is decided by
   passing around a parameter, Depth.  This can take a value of 0 or 1.
   A depth value of 0 indicates an "outer disjunction", i.e. a goal of
   the form ( (c1 OR c2) AND c3 ).  A depth value of 1 indicates an "inner
   disjunction", e.g. the inner OR in the case ((c1 OR (c2 OR c3)) AND c4).
   This information is used to determine when to generate the label
   corresponding to the "meet" label: this is generated if and only if
   (i) a meet exists, i.e. is nonvariable, and (ii) the depth is 0.  If
   these conditions are met, the meet label is generated and the depth set
   to 1 so that duplicate labels are not produced.

   Things are complicated by the fact that we generally only look at the
   outermost connective (it is expensive to search the tree all the time).
   Thus, it is possible to have a goal of the form
   		( (c1 AND (c2 OR c3) ) AND c4 )
   Here, the paths should come together before c4.  This can be handled as
   before, as it turns out: if the goal is of the form ((c1 OR c2) AND c3),
   then a new meet is generated and passed into the first conjunct (i.e.
   (c1 OR c2), together with a new depth of 0; the meet and depth values
   passed down into the second conjunct c2 are what was passed in from
   above, since this is where the execution paths should subsequently come
   together, if necessary.

*/

$tbody(and(Goal,_,Goals),A,Pil,Pilr,Tin,Tout,OldMeet,OldDepth,HoldRegs) :- 
    (($tprog_contains_branch(Goal),
      NewMeet = meet((branch_targ,-1,MeetLab)), NewDepth = 0,
      $gennum(MeetLab)
     ) ;
     (NewMeet = OldMeet, NewDepth = OldDepth)
    ),
    $tbody(Goal,A,Pil,Pil1,Tin,Tmid,NewMeet,NewDepth,HoldRegs),
    $tbody(Goals,A,Pil1,Pilr,Tmid,Tout,OldMeet,OldDepth,HoldRegs), !.
$tbody(if_then_else(Test,P,TGoal,FGoal),A,Pil,Pilr,Tin,Tout,M,D,HoldRegs0) :-
    $gennum(TLabId), $disj_targ_label(TLabId,TLabel),
    $gennum(FLabId), $disj_targ_label(FLabId,FLabel),
    $member1(tvars(TV),P),
    $append(TV,HoldRegs0,HoldRegs1),
    TrueLabel = label((TLabel,-1,TLabId)),
    FalseLabel = label((FLabel,-1,FLabId)),
    $tcond(Test,TrueLabel,FalseLabel,Pil,[TrueLabel|Pilm],Tin,Tmid,HoldRegs1),
    $cond_branch(Pil1,Pilr,FalseLabel,Pil2,Pil3,M,D,ND),
    $tbody(TGoal,A,Pilm,Pil2,Tmid,Tout0,M,ND,HoldRegs1),
    $merge(Tmid,Tout0,Tout1),
    $tbody(FGoal,A,Pil1,Pil3,Tout1,Tout2,M,ND,HoldRegs0), /* tvar may be in */
    $merge(Tout1,Tout2,Tout), !.		/* branches of an i-t-e */
$tbody(or(Goal,_,Goals),A,Pil,Pilr,Tin,[],Meet,Depth,HoldRegs) :-
    NDisj = (disj_targ,-1,NDisjNum), $gennum(NDisjNum),
    $tprog_getnvars(Goal,Nv),
    XPil = [call( (DLabel,-1),Nv),
    	    label((DLabel,-1,LabId)),trymeelse(NDisj,0)|XPil1],
    $gennum(LabId), $disj_targ_label(LabId,DLabel),
    $disj_branch(Pil1,Pilr,NDisj,Pilm1,Pilm2,Meet,Depth,NewDepth),
    $tbody(Goal,A,XPil1,Pilm1,Tin,_,Meet,NewDepth,HoldRegs),
    $tbody(Goals,A,Pil1,Pilm2,Tin,_,Meet,NewDepth,HoldRegs),
    $optimize_CP(XPil,Pil), !.

$tbodycall(Args,A,Pil,Pilr,Tin,Tout,_,_,HoldRegs,Pred,CPrag) :-
    $member1(lastlit,CPrag),
    !,
    $length(Args, Arity),
    (($inline(Pred,Arity), 
      ((A = y, Pil1 = [deallocate,proceed|Pilr]) ;
       (A = n, Pil1 = [proceed | Pilr])
      ),
      $geninline(Pred,Args,HoldRegs,Pil,Pil1,Tin,Tout)
     ) ;
     (((A = y, Pil1 = [deallocate,execute((Pred,Arity))|Pilr]) ;
       (A = n, Pil1 = [execute((Pred,Arity)) | Pilr])
      ),
      $reserve(Arity,Tin,T1), Tout = [],
      $tgoalargs(Args,1,Pil,Pil1,CPrag,T1,_)
     )
    ).
$tbodycall(Args,_,Pil,Pilr,Tin,Tout,_,_,HoldRegs,Pred,CPrag) :-
    $length(Args, Arity),
    (($inline(Pred,Arity),
      $geninline(Pred,Args,HoldRegs,Pil,Pilr,Tin,Tout)
     ) ;
     (($member1(nv(Nv), CPrag),
       $reserve(Arity,Tin,T1), Tout = [],
       $tgoalargs(Args,1,Pil,[call((Pred,Arity),Nv)|Pilr],CPrag,T1,_)
      )
     )
    ).


$tprog_contains_branch(and(C1,_,C2)) :-
	$tprog_contains_branch(C1) ;
	$tprog_contains_branch(C2).
$tprog_contains_branch(or(_,_,_)).
$tprog_contains_branch(if_then_else(_,_,_,_)).

$tprog_getnvars('_call'(_,_,CPrag), NVars) :-
	(($member1(nv(NVars),CPrag),
	  (NVars = 0 ; true)) ;
	 NVars = 0
	).
$tprog_getnvars(and(Goal,_,_),NVars) :- $tprog_getnvars(Goal,NVars).
$tprog_getnvars(or(Goal,_,_),NVars) :- $tprog_getnvars(Goal,NVars).
$tprog_getnvars(not(Goal,_),NVars) :- $tprog_getnvars(Goal,NVars).
$tprog_getnvars(if_then_else(_,_,Goal,_),NVars) :- $tprog_getnvars(Goal,NVars).

$get_indexinst(IList,IndexInst) :- 
	var(IList) ->
		IndexInst = [] ;
		(IList = [Inst|IRest],
		 (Inst = label(_) ->
		    IndexInst = IndInstRest ; IndexInst = [Inst|IndInstRest]
		 ),
		 $get_indexinst(IRest,IndInstRest)
		).

$subst_exec(Pil,P,N,IList,Pil0,Pilr) :-
	var(Pil) ->
		Pil0 = Pilr ;
		(Pil = [Inst|IRest],
		 (Inst = execute((P,N)) ->
		 	$subst_exec1(IList,Pil0,Pil1) ;
			Pil0 = [Inst|Pil1]
		 ),
		 $subst_exec(IRest,P,N,IList,Pil1,Pilr)
		).

$subst_exec1([],L,L).
$subst_exec1([I|IRest],[I|LRest],L) :- $subst_exec1(IRest,LRest,L).

$tail_rec([clause(_,Body,_)|ClRest],P,N) :-
	$tail_rec1(Body,P,N) ;
	$tail_rec(ClRest,P,N).

$tail_rec1('_call'(P,Args,_),P,N) :- $length(Args,N).
$tail_rec1(and(_,_,G),P,N) :- $tail_rec1(G,P,N).
$tail_rec1(if_then_else(_,_,G1,G2),P,N) :- $tail_rec1(G1,P,N) ; $tail_rec1(G2,P,N).
$tail_rec1(or(G1,_,G2),P,N) :- $tail_rec1(G1,P,N) ; $tail_rec1(G2,P,N).

/* end $tprog1.P *************************************************/