Mercurial > hg > Applications > Tokio

comparison tr.pl @ 0:cfb7c6b24319

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Initial revision
author kono
date Thu, 30 Aug 2007 14:57:44 +0900
parents
children 61743469ee56
comparison
equal deleted inserted replaced
-1:000000000000 0:cfb7c6b24319
1 /*
2 Copyright (C) 1988,2005, Shinji Kono
3 Everyone is permitted to copy and distribute verbatim copies
4 of this license, but changing it is not allowed. You can also
5 use this wording to make the terms for other programs.
6
7 send your comments to kono@ie.u-ryukyu.ac.jp
8 */
9
10 /*
11
12 Tokio to prolog compiler
13 Runtime routine
14 with register list
15
16 Mon Aug 5 09:01:29 JST 1985
17 fix put_queue Fri Jan 24 11:47:11 JST 1986
18 add tracer Sun Jun 22 12:47:21 JST 1986
19 fix empty/notempty Wed Mar 9 09:24:47 JST 1988
20 reducing compile time Fri Oct 14 03:27:08 JST 1988
21 add mcom and fix chop Sat Aug 5 22:25:15 JST 1989
22 meta call supported Sun Aug 6 00:55:42 JST 1989
23 $Header$
24 */
25
26 :-dynamic(r_fififi/1).
27 :-dynamic(r_skip/1).
28
29 r_header :-
30 write('
31 Tokio to prolog compiler $Revision$ $Date$
32 try ?- tokio_help.
33 ').
34
35 user_help :- tokio_help.
36 tokio_help :-
37 nl, r_header,nl,
38 write(' com(File). : compile & compile program. '),nl,
39 write(' com(File,Output).: compile & counsult & save file. '),nl,
40 write(' pcom(File,Predicate-heads). : compile specified predicates. '),nl,
41 write(' pcom(File,Predicate-heads,Output).: compile specified predicates. '),nl,
42 write(' mcom(File). : preprocess '),nl,
43 write(' mcom(File,Output).: preprocess & outputfile.'),nl,
44 write(' restart(File). : run tokio save file. '),nl,
45 write(' tokiodebug. : All computation will be traced. '),nl,
46 write(' tokionodebug. : Debug mode is switched off. '),nl,
47 write(' tokiodebugging. : Display some informations about tracing. '),nl,
48 write(' notimebacktrack. : no time backtrack.. '),nl,
49 write(' timebacktrack. : time backtrack.. '),nl,
50 write(' tokio. : start tokio top-level. '),nl,
51 write(' tokio predicate. : run tokio program. '),nl,
52 write(' reset_macro. : Reset Macro Definition. com predicates also reset Macros.'),nl.
53 % write(' tokiospy : All predicate will be traced. '),nl,
54 % write(' tokiospy(F/N) : Predicate F which have N arity will be traced.'),nl,
55 % write(' tokionospy : All spy point are removed. '),nl,
56 % write(' tokionospy(F/N) : Spy point F/N will be removed. '),nl,
57 % write(' tokiodebugat(T) : Tracing will be start at time=Time. '),nl,
58 % write(' tokionodebugat : Start point of tracing is removed. '),nl,
59
60 r_tokio0(Goals) :-
61 cputime(Time),
62 r_do_solve(Goals, C),
63 cputime(Time1),
64 T is (Time1-Time), % sec
65 r_tokiostats(C, T).
66 r_tokio0(_Goals) :- nl, write('--fail--'), nl.
67
68 r_do_solve(Goals,C) :-
69 r_put_queue(Goals, X, true, Q, Q1),
70 r_notEmpty(Q),
71 ( recorded(tokiodebug, on, _), !,
72 r_solve_t(X,C,0,Q,Q1);
73 recorded(timebacktrack, off, _), !,
74 r_solve_d(X,C,0,Q,Q1);
75 r_solve(X,C,0,Q,Q1)).
76
77 notimebacktrack :- recorded(timebacktrack,_,Ref),erase(Ref),fail.
78 notimebacktrack :- recorda(timebacktrack,off,_Ref).
79 timebacktrack :- recorded(timebacktrack,_,Ref),erase(Ref),fail.
80 timebacktrack :- recorda(timebacktrack,on,_Ref).
81
82 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
83 % Quick and Easy Compile
84 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
85 r_put_queue(X, Y, Y, Q, Q) :- var(X),!,
86 write('cannot call variable:'),write(X),nl.
87 r_put_queue(X, (unifyNow(X,Xn),Xn,Y), Y, Q, Q) :- systemp(X),!.
88 % Tokio's varible is local, so, meta call is also local to
89 % its value. But I don't care about its arguments.
90 r_put_queue('$t'(Now,_Next),Z, Z1,Q, Q1) :- !,
91 r_put_queue(Now, Z, Z1,Q, Q1).
92 r_put_queue((X,Y), Z, Z1, Q, Q1) :- !,
93 r_put_queue(X,Z, Z2, Q,Q2),
94 r_put_queue(Y,Z2,Z1,Q2,Q1).
95 r_put_queue(#P, (r_always(P,Q,Q1),Y), Y, Q, Q1) :- !.
96 r_put_queue(next(P), (r_next(P,Q,Q1),Y), Y, Q, Q1) :- !.
97 r_put_queue(length(N), (r_length(M,Q),Y), Y, Q, Q) :- !, % restricted length
98 M is N.
99 r_put_queue(P, (P1,Y), Y, Q, Q1) :-
100 functor(P, H, N), N2 is N+2, N1 is N+1,
101 functor(P1, H, N2), arg(N1, P1, Q), arg(N2, P1, Q1),
102 r_put_queue_arg(N,P,P1).
103
104 r_put_queue_arg(0,_,_) :- !.
105 r_put_queue_arg(M,F,F1) :-
106 arg(M,F,FA),arg(M,F1,FA),M1 is M-1,
107 r_put_queue_arg(M1,F,F1).
108
109 r_tokiostats(L, T) :- nl,
110 write(L), write(' clock and '),
111 write(T), write(' sec. '), nl.
112
113 r_always(X,['$t'((r_always(Xn,Q,Q2),N),F,E,C)|Q],Q1) :-
114 unifyNowNext(X,Xx,Xn),
115 'tokio_call'(Xx,['$t'(N,F,E,C)|Q2],Q1).
116 r_next(X,['$t'(N,F,E,C)|Q], % same as next(tokio_call(X))
117 ['$t'(N1,F,E,C)|Q1]) :- unifyNext(X,Xn),
118 r_put_queue(Xn,N,N1,Q,Q1).
119
120 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
121 % Tokio Temporal Resolution
122 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
123 r_solve(r_end,_Fin,_Now,_X,_Y) :- !.
124 r_solve(X,Fin,Now,['$t'(Next,F,K,'$'(Fin,Now,Empty))|Futures],
125 ['$t'(true,true,true,'$'(Fin,Now,Empty))|True]) :-
126 NextTime is Now+1,
127 nl,write('t'),write(Now),write(':'),ttyflush,
128 call(X),
129 r_exec_fin_keep(Empty,Fin,Now,F,K,Next,Next1),
130 r_solve(Next1, Fin, NextTime, Futures, True).
131 r_solve(_,_,Now,_,_) :- B is Now-1, B>0, nl,write(b),write(B),write(':'),
132 ttyflush,!,fail.
133
134 r_solve_t(r_end,_Fin,_Now,_X,_Y) :- !.
135 r_solve_t(X,Fin,Now,['$t'(Next,F,K,'$'(Fin,Now,Empty))|Futures],
136 ['$t'(true,true,true,'$'(Fin,Now,Empty))|True]) :-
137 r_tokioDebug(t(Empty,X,Fin,Now,F,K,Next,Futures,True),Now),
138 NextTime is Now+1,
139 nl,write('t'),write(Now),write(':'),ttyflush,
140 call(X),
141 r_exec_fin_keep(Empty,Fin,Now,F,K,Next,Next1),
142 r_solve_t(Next1, Fin, NextTime, Futures, True).
143 r_solve_t(_,_,Now,_,_) :- B is Now-1, B>0, nl,write(b),write(B),write(':'),
144 ttyflush,!,fail.
145
146 r_solve_d(r_end,_Fin,_Now,_X,_Y) :- !.
147 r_solve_d(X,Fin,Now,['$t'(Next,F,K,'$'(Fin,Now,Empty))|Futures],
148 ['$t'(true,true,true,'$'(Fin,Now,Empty))|True]) :-!,
149 NextTime is Now+1, call(X),
150 r_exec_fin_keep(Empty,Fin,Now,F,K,Next,Next1),
151 r_solve_d(Next1, Fin, NextTime, Futures, True).
152
153 r_exec_fin_keep(empty, Fin, Fin, F, _, _, r_end) :- !, % end at this time
154 call(F).
155 r_exec_fin_keep(notEmpty, Now, Fin, _, K, Next, Next) :-
156 Now \== Fin,
157 call(K).
158
159 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
160 % Chop Operator Runtime
161 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
162 r_subBegin(['$t'(_,_,_,'$'(_,Now,_))|Q], % original interval
163 ['$t'((r_subBegin(Q,SQ,SQ1,Fin),N),F,K,'$'(Fin,Now,E))|SQ],
164 ['$t'(N,F,K,'$'(Fin,Now,E))|SQ1],Fin). % subinterval's Fin
165
166 r_subFin( ['$t'(_, F , _, '$'(Fin,Fin,empty)) | _ ], % outer fin?
167 ['$t'(_, true, _, '$'(Fin,Fin,empty)) | _ ]) :-
168 call(F).
169
170 r_subNotFin( LaterLoop, '$'(Q,Q1,QF,QF1),
171 ['$t'(N, F, K, '$'(OuterFin,Now,notEmpty)) | Q ],
172 ['$t'(N1, F1, K1, '$'(OuterFin,Now,notEmpty)) | Q1 ],
173 ['$t'(N, F, K, '$'(Fin,Now,Empty)) | QF ],
174 ['$t'((LaterLoop,N1), F1, K1, '$'(Fin,Now,Empty)) | QF1 ]) :-
175 r_sub_check(OuterFin,Now,Fin).
176
177 r_sub_check(OuterFin,Now,Fin) :- var(OuterFin),!,
178 r_sub_check2(Fin,Now).
179 r_sub_check(OuterFin,Now,Fin) :-
180 OuterFin > Now,r_sub_check3(OuterFin,Now,Fin). %%%% Fin > Now, OuterFin > Now
181 r_sub_check2(Fin,_Now) :- var(Fin),!. %%%% freeze(Fin,Fin>Now).
182 r_sub_check2(Fin,Now) :- Fin>Now.
183 r_sub_check3(_OuterFin,_Now,Fin) :- var(Fin),!. %%%% freeze(Fin,(N<F,F<O))
184 r_sub_check3(OuterFin,Now,Fin) :- Now<Fin,Fin<OuterFin.
185
186 %%%%%%%%%%%%%%%%%%%%%%%%%
187 % meta call ( same restriction as top level )
188 %%%%%%%%%%%%%%%%%%%%%%%%%
189 tokio_call(A,Q,Q) :- var(A),!,
190 write('uninstantiated meta call'),nl.
191 tokio_call(A,Q,Q1) :-
192 r_put_queue(A, X, true, Q, Q1),
193 call(X).
194
195 %%%%%%%%%%%%%%%%%%%%%%%%%
196 % Tokio System Call
197 %%%%%%%%%%%%%%%%%%%%%%%%%
198 % Thanks for Prof. Esterline and Dr. Kilis
199 r_empty(['$t'(_,_,_,'$'(F,F,empty))|_]).
200 r_notEmpty(['$t'(_,_,_,'$'(F,N,notEmpty))|_]):- F\==N.
201
202 r_length( 0, ['$t'(_,_,_,'$'(Fin,Fin,empty))|_] ) :-!.
203 r_length( L, ['$t'(_,_,_,'$'(Fin,Now,notEmpty))|_] ) :-
204 Fin is Now+L.
205
206 r_cputime(X) :- statistics(runtime,[X1,_]),X is X1/1000.
207 r_cputime(X,Q,Q) :- r_cputime(X).
208
209
210 %%%%%%%%%%%%%%%%%%%%%%%%%%%
211 % Static Variable Runtime
212 %%%%%%%%%%%%%%%%%%%%%%%%%%%
213 r_set_value(Name,Value) :- var(Value),!,
214 write('Assign non fixed value = '),
215 write(Name),nl.
216 r_set_value(Name,Value) :-
217 %%%%%%% r_check(Name,Time),
218 recorded(Name,(Name,V,_Time),_),!,V=Value.
219 r_set_value(Name,Value) :-
220 %%%%%%% r_check(Name,Time),
221 recorda(Name,(Name,Value,_Time),_).
222 r_set_value(Name,Value) :-
223 recorded(Name,(Name,Value,_),Ref),
224 erase(Ref),!,fail.
225
226 r_set_value(Name,Value,_Time) :- var(Value),!,
227 write('Assign non fixed value = '),
228 write(Name),nl.
229 r_set_value(Name,Value,Time) :-
230 recorded(Name,(Name,V,Time),_),!,V=Value.
231 r_set_value(Name,Value,Time) :-
232 recorda(Name,(Name,Value,Time),_).
233 r_set_value(Name,Value,Time) :-
234 recorded(Name,(Name,Value,Time),Ref),
235 erase(Ref),!,fail.
236
237 % Special Cases
238
239 % #(A=B)
240 % variable vs varible
241 % variable vs time constance
242 % *i <= ??
243
244 r_eq(A,B,['$t'((r_eq(C,D,E,F),G),H,I,J)|E],['$t'(G,H,I,J)|F]) :-
245 unifyNowNext(A,K,C),unifyNowNext(B,K,D).
246 r_eqn(A,B,['$t'((r_eqn(C,B,D,E),F),G,H,I)|D],['$t'(F,G,H,I)|E]) :-
247 unifyNowNext(A,B,C).
248 r_assign(Static,A,['$t'((r_assign(Static,A,B,C),D),(r_set_value(Static,A,Time),E),F,G)|B],
249 ['$t'(D,E,F,G)|C]):- G='$'(_Fin,Time,_Empty).
250
251
252
253 % r_check(Name,Time) :-
254 % recorded(time,Time,_),
255 % ( recorded(Name,(Name,Value1,Time),_),
256 % report_conflict(Name,Name,Time)
257 % ; true),
258 % ( recorded(r_write,(Name,Bus),_),(
259 % recorded(Bus,(Name2,Time),_),
260 % report_conflict(Name,Name2,Time)
261 % ; recorda(Bus,(Name,Time),_))
262 % ; true),!.
263
264 r_read_value(Name,Value) :- recorded(Name,(Name,Value1,_),_),!,
265 % recorded(time,Time,_),
266 % recorda(Name,(Name,Value1,Time),_),
267 % ( recorded(r_read,(Name,Bus),_),(
268 % recorded(Bus,(Name2,Time),_),Name2 \= Name,
269 % report_conflict(Name,Name2,Time)
270 % ; recorda(Bus,Name,_))
271 % ; true),!,
272 Value = Value1.
273 r_read_value(Name,_Value) :- nl,
274 write('Reference Not assigned value -- '),
275 write(Name),nl.
276
277 init_static :- recorded(r_static,Name,_),recorded(Name,_,Ref),
278 erase(Ref),fail.
279 init_static :- abolish(r_skip,1),
280 assert(r_skip(-1)).
281
282 reset_static :- recorded(r_static,Name,Iref),recorded(Name,_,Ref),
283 erase(Ref),erase(Iref),fail.
284
285 static([]) :- !.
286 static([H|T]) :- !,static(H),static(T).
287
288
289 % static(Name=Bus) :- !,static(Name),static(Bus),
290 % r_read_bus(Name,Bus),r_write_bus(Name,Bus).
291 % static(Name=[RBus,WBus]) :- !,static(Name),static(Bus),
292 % r_read_bus(Name,RBus),r_write_bus(Name,WBus).
293 static(Name) :- functor(Name,_H,_),recorded(r_static,Name,_),!.
294 static(Name) :- functor(Name,_H,_),recordz(r_static,Name,_).
295
296 static_memory(L) :- static(L).
297 static_register(L) :- static(L).
298
299 r_read_bus(Name,Bus) :-
300 (recorded(r_read,(Name,Bus),_);recordz(r_read,(Name,Bus),_)).
301 r_write_bus(Name,Bus) :-
302 (recorded(r_write,(Name,Bus),_);recordz(r_write,(Name,Bus),_)).
303
304 /* :- static(time). */
305
306 % r_report_conflict(Name,Name2,Time) :- nl,
307 % write('Conflict *'),
308 % write(Name),write(' and *'),
309 % write(Name2),write(' at '),
310 % write(Time).
311
312 % A \= A :-!,fail.
313 % _ \= _.
314
315 append([],X,X).
316 append([H|X],Y,[H|Z]) :- append(X,Y,Z).
317
318 member(H,[H|_]) :-!.
319 member(H,[_|T]) :- member(H,T).
320
321 /* for ttyflush */
322
323 /* :- (ttyflush ; assert(ttyflush) ). */
324
325 /* end of runtime */