vm-args.scm 4.67 KB
Newer Older
1
(define-module (logic guile-log guile-prolog vm vm-args)
2 3 4 5 6
  #:use-module (logic guile-log)
  #:use-module (logic guile-log iso-prolog)
  #:use-module (logic guile-log guile-prolog hash)
  #:use-module (logic guile-log guile-prolog ops)
  #:use-module (logic guile-log prolog swi)
7
  #:use-module (logic guile-log guile-prolog vm vm-pre)
8
  #:use-module (logic guile-log guile-prolog vm vm-var)
9 10
  #:use-module (compat racket misc)
  #:use-module (system vm assembler)
11 12 13 14
  #:export (caller push_args_args2 push_args_args push_args
		   ))

(compile-prolog-string "'with-cut'. 'without-cut'.")
15

16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
#|
By setting a procedure as 'with-cut we can pass under the radar
|#
(<define> (argkind f k)
  (let ((f (<lookup> f)))
    (if (procedure? f)
	(case (procedure-property (<lookup> f) 'argkind)
	  ((with-cut)
	   (<=> k with_cut))
	  ((without-cut)
	   (<=> k without_cut))
	  (else
	   (<=> k #f)))
	(<=> k #f))))

31
(compile-prolog-string "
32
narg(X,N,N) :- var_p(X),!.
33 34 35 36 37
narg([X|L],I,N) :-
  II is I + 1,
  narg(L,II,N).
narg(_,I,I).

38
push_code_with_cut(X,Label,V,L,LL) :-
39
  L=[[label,Label],[clean-sp]|LX],
40 41 42
  compile_goal(X,#t,V,[LX,LL]).

push_code_without_cut(X,Label,V,L,LL) :-
43
  L=[[label,Label],[clean-sp]|LX],
44 45
  compile_goal(call(X),#t,V,[LX,LL]).

46
push_args_args(K,X,V,L,LL,_,_) :- var_p(X),!,K==#f,
47 48
  push_args(X,V,L,LL).

49
push_args_args(#f,[X|Y],V,L,LL,U,U) :- !,
50
  push_args(X,V,L,L1),
51
  push_args_args(#f,Y,V,L1,LL,U,U).
52

53
push_args_args(with_cut,[X|Y],V,L,LL,LW,LLW) :- !,
54
  L=[['push-closure',Label]|L1],
55
  push_code_with_cut(X,Label,V,LW,LLW),
56
  push_args_args(with_cut,Y,V,L1,LL).
57 58

push_args_args(without_cut,[X|Y],V,L,LL,LW,LLW) :- !,
59
  L=[['push-closure',Label]|L1],
60
  push_code_without_cut(X,Label,V,L,L1),
61
  push_args_args(without_cut,Y,V,L1,LL).
62 63

push_args_args(_,[],V,L,L,LW,LW) :- !.
64

65
push_args_args2(X,V,L,LL) :- var_p(X),!,
66 67 68
  push_args(X,V,L,LL).

push_args_args2([X|Y],V,L,LL) :- !,
69 70
  push_args(X,V,L,L1),
  push_args_args2(Y,V,L1,LL).
71 72 73 74

push_args_args2([],V,L,LL) :-
  push_args([],V,L,LL).

75
push_args(X,V,L,LL) :- var_p(X),!,
76 77 78 79 80 81 82
  add_var(X,V,Tag),
  push_v(1,V),
  tr('push-variable',Push),
  L=[[Push,Tag]|LL].

push_args([X|Y],V,L,LL) :- !,
  tr('mk-cons',Cons),
83 84 85
  push_args(X,V,L,L1),
  push_args(Y,V,L1,L2),
  push_v(-1,V),
86 87 88 89 90
  L2=[[Cons]|LL].

push_args(X(|Y),V,L,LL) :- !,
  tr('mk-fkn',Fkn),
  narg(Y,0,NN),N is NN + 1,
91 92
  push_args_args2([X|Y],V,L,L1),
  M is -N, push_v(M,V),
93 94 95 96 97 98 99 100
  L1=[[Fkn,N]|LL].

push_args({X},V,L,LL) :- !,
  tr('mk-curly',MK),
  push_args(X,V,L,L1),
  L1=[[MK]|LL].

push_args(X,V,L,LL) :-
101
  push_v(1,V),
102 103 104 105 106 107
  (
    constant(X) -> 
     (tr('push-constant',Push),regconst(X,XX),L=[[Push,XX]|LL]) ; 
    (tr('push-instruction',Push),L=[[Push,X]|LL])
  ).

108 109 110 111 112 113 114 115 116 117 118 119
get_post(S,C,Cplx,Tail,X,XX) :-
  Tail==#t -> X=XX ;
  (
    (S==0,C==0) ->
       (
         Cplx==#f ->
           (
             tr(pop,Pop),
             X=[[Pop,3]|XX]
           ) ;
          X=XX
       );
120
    Cplx==#f ->
121
       (
122
          tr('post-call',Post),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
123
          X=[[Post,C,#t]|XX]
124 125
       );
    (
126 127
       tr('post-call',Post),
       X=[[Post,C,#f]|XX]
128 129 130 131
    )
  ).

caller(cc,Args,label(G,N),V,[L,LL]) :- !,
132
  touch_Q(V),
133
  narg(Args,0,MM),
134 135 136 137
  M is MM + 3,
  (M==N -> true ; throw(cc_does_not_match_caller)),
  tr('clear-sp' , Clear),
  L=[[Clear]|L2],
138
  get_S(V,S),
139 140 141
  set_S(V,0),
  push_v(2,V),
  tr(seek,Seek),
142
  L2=[[Seek,3]|L4],
143
  push_args_args(#f,Args,V,L4,LL2,_,_),
144
  tr('goto-inst', Goto),
145 146 147
  LL2 = [[Goto,G]|LL].

caller(cc,Args,Tail,V,[L,LL]) :- !,
148
  touch_Q(V),
149 150 151
  (Tail=#f -> throw(cc_not_in_tail_context) ; true),
  tr('clear-sp' , Clear),
  L=[[Clear]|L2],
152
  get_S(V,S),
153 154 155 156 157
  set_S(V,0),
  push_args(F,V,L2,L3),
  push_v(2,V),
  tr(seek,Seek),
  L3=[[Seek,2]|L4],
158
  push_args_args(#f,Args,V,L4,LL2,_,_),
159 160
  set_FS(V,F,S),
  tr('tail-cc', Call),
161
  LL2 = [[Call]|LW].
162

163
caller(F,Args,Tail,V,[L,LL]) :-
164
  touch_Q(V),
165 166
  get_recur(F,A,N) -> rec(F,A,N,Args,Tail,V,[L,LL]) ;
  (   
167 168
  tr('clear-sp' , Clear),
  L=[[Clear]|L2],
169
  get_CS(V,[C|_],S),
170
  set_S(V,0),
171
  push_args(F,V,L2,L3),
172
  push_v(3,V),
173 174
  tr(seek,Seek),
  L3=[[Seek,3]|L4],
175
  argkind(F,K),
176
  push_args_args(K,Args,V,L4,LL2,LW,LL),
177
  touch_A(V),
178
  set_FS(V,scm[(gensym \"F\")],S),
179 180 181
  (Tail == #t -> 
    (  
      tr('tail-call', Call), 
182
      LL2 = [[Call]|LW]
183 184 185
    );
   Tail = label(G,N) ->
    (
186
       tr(goto-inst,Goto),
187
       tr('call-n',Call),
188
       LL2 = [[Call,N],[Goto,G]|LW]
189 190 191 192
    );
   (
      tr('call', Call),
      LL2=[[Call]|LLL], 
193
      get_post(S,C,#f,Tail,LLL,LW)
194
   )
195 196 197 198 199 200 201 202
  )).

rec(F,A,N,Args,Tail,V,[L,LL]) :-
  (narg(Args,0,N) -> true ; throw(recur_call_wrong_number_of_arguments(F))),
  tr('clear-sp' , Clear),
  L=[[Clear]|L2],
  get_CS(V,[C|_],S),
  set_S(V,0),
203
  push_args_args(#f,Args,V,L2,LL2,_,_),
204 205 206
  touch_A(V),
  set_FS(V,F,S),
  (
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
207 208
    tr('goto-inst',Goto),
    LL2 = [[Goto,A]|LL]
209
  ).
210
")
211 212