bootstrap
view genesis/ometa/ometa-interpreter.church @ 867:3557dbdaf618
add new macros for getting and setting array values, which can work on both byte and word sized arrays
comment out some debugging print statements
comment out some debugging print statements
| author | John Leuner <jewel@subvert-the-dominant-paradigm.net> |
|---|---|
| date | Sun Apr 15 19:17:11 2012 +0200 (4 weeks ago) |
| parents | b937c15aa55d |
| children |
line source
1 extern o-fail
3 class ometa-rule
4 with-slots
5 name
6 instructions
7 original-instructions
8 variables
9 variables-length
10 transient?
11 rule-number
12 reference-count
14 print r:ometa-rule
15 out "<"
16 out r.name
17 out " ("
18 out r.reference-count
19 out ") "
20 out (if r.transient? "transient " "")
21 out r.variables
22 out " ; "
23 print r.instructions
25 ; for performance, inline these calls
26 ; note this breaks encapsulation
28 macro _o-fail? arg
29 <<
30 eq? \arg o-fail
31 >>
33 macro _unsafe-array-length array
34 <<
35 __v = \array
36 inline (deref (band __v LOWTAG_MASK) 16)
37 >>
39 ; no performance improvement
40 macro at-end? stream
41 <<
42 (== (\stream).input-position (_unsafe-array-length (\stream).input-array))
43 >>
45 get-variable-position rule-variables sym
46 (position sym rule-variables)
48 replace-variables-with-positions variables form quoting
49 typecase form
50 nil nil
51 cons
52 cond
53 (and quoting (eq? (first form) 'unquote))
54 pos = position (second form) variables
55 `[_ometa_get_variable ,pos]
56 (and quoting (eq? (first form) 'unquote-splice))
57 pos = position (second form) variables
58 `[_ometa_get_variable_splice ,pos]
59 (eq? (first form) 'quote)
60 (replace-variables-with-positions variables (second form) true)
61 (eq? (first form) 'quasiquote)
62 loop
63 for f in (second form)
64 collect (replace-variables-with-positions variables f true)
65 true
66 loop
67 for f in form
68 collect (replace-variables-with-positions variables f quoting)
69 else
70 if (string? form)
71 form
72 else
73 if quoting
74 `[quote ,form]
75 else
76 pos = get-variable-position variables form
77 if (null? pos)
78 error "var not found " (list form variables)
79 `[_ometa_get_variable ,pos]
84 class ometa-interpreter
85 with-slots
86 data-stack
87 rules
88 rules-map
89 memo-table
90 column-size
91 actions
92 instructions-map
93 ins-profile-map
94 ; call-profile-map
95 ; current-rule
96 ; tracing
97 init
98 ; self.two-key-memo = new 'two-key-dictionary
99 ; reset-memo self
100 ; self.ins-profile-map = new 'dictionary
101 ; create self.ins-profile-map 10000
102 ; self.call-profile-map = new 'dictionary
103 ; create self.call-profile-map 10000
104 self.instructions-map = new 'dictionary
105 create self.instructions-map 10000
106 self.actions = nil
107 ; self.current-rule = nil
108 reset-memo input-size
109 ; create self.two-key-memo 50000
110 ; self.current-rule = list 'top
111 self.memo-table = make-array (+ input-size 1) 4
112 rewrite-instruction rule form count-references
113 ; by using an equal-dictionary to 'intern' sequences of the same instructions
114 ; we are able to let the memoization in the parser share the same cache value
115 ; for identical sequences of instructions present in different rules
116 new-form = actual-rewrite-instruction self rule form count-references
117 lookup = get self.instructions-map new-form nil
118 if (null? lookup)
119 put self.instructions-map new-form new-form
120 new-form
121 else
122 lookup
123 actual-rewrite-instruction rule form count-references
124 ; print "rewrite-instruction 3"
125 ; print form
126 case (first form)
127 and
128 new-forms = [(rewrite-instruction self rule x count-references) for x in (cdr form)]
129 `[and |,(remove nil new-forms)]
130 or
131 new-forms = [(rewrite-instruction self rule x count-references) for x in (cdr form)]
132 `[or |,(remove nil new-forms)]
133 set
134 ; print "set"
135 ; print form
136 ; print rule.variables
137 rhs = third form
138 var-name = second form
139 if (not (symbol? var-name))
140 var-name = intern var-name
141 variable-position = get-variable-position rule.variables var-name
142 `[set ,variable-position ,(rewrite-instruction self rule rhs count-references)]
143 app
144 rule-name = second form
145 if (and (string? rule-name) (string-equal? rule-name "token"))
146 return-from actual-rewrite-instruction `[app-token ,rule-name ,(coerce rule-name 'array)]
147 if (eq? rule-name 'token)
148 str = (third form)
149 `[app-token ,str ,(coerce str 'array)]
150 else
151 if (eq? rule-name 'exactly)
152 args = cddr form
153 str = third form
154 if (cons? str)
155 str = second str
156 `[match-char ,(char-at str 0)]
157 else
158 ; print form
159 if (== (length form) 3)
160 if (and (cons? (third form)) (eq? (first (third form)) 'string))
161 `[app-with-string ,(intern (second form)) ,(second (third form))]
162 else
163 if (or (null? (third form)) (or (null? (third form)) (eq? 'nil (third form)) (string-equal? (third form) "nil")))
164 if (symbol? (second form))
165 `[app-with-nil ,(second form)]
166 else
167 `[app-with-nil ,(intern (second form))]
168 else
169 rule-name = second form
170 if (string? rule-name)
171 rule-name = intern rule-name
172 ; called-rule = get self.rules-map rule-name nil
173 ; if (not (null? called-rule))
174 ; if count-references
175 ; if (null? called-rule.reference-count)
176 ; called-rule.reference-count = 0
177 ; called-rule.reference-count = + called-rule.reference-count 1
178 `[app-with-argument ,(second form) ,(get-variable-position rule.variables (intern (third form)))]
179 else
180 calling-rule = rule
181 if (== (length form) 2)
182 rule-name = second form
183 if (string? (second form))
184 rule-name = intern rule-name
185 rule = get self.rules-map rule-name nil
186 if (null? rule)
187 `[app-no-memo ,rule-name]
188 else
189 if count-references
190 if (null? rule.reference-count)
191 rule.reference-count = 0
192 rule.reference-count = + rule.reference-count 1
193 if rule.transient?
194 `[app-rule-no-memo ,rule]
195 else
196 `[app-rule ,rule]
197 else
198 error "bad app form" form
199 act
200 ; print "*** rewrite act"
201 ; print rule.variables
202 ; print form
203 ; print (coerce (second form) 'array)
204 forms = (parse-sexps-from-array (coerce (second form) 'array))
205 if (null? forms)
206 error "bad sexp" form
207 act-form = first forms
208 ; print "act-form"
209 ; print act-form
210 res = `[act ,(replace-variables-with-positions rule.variables act-form nil)]
211 res
212 many
213 `[many ,(rewrite-instruction self rule (second form) count-references)]
214 many1
215 `[many1 ,(rewrite-instruction self rule (second form) count-references)]
216 not
217 `[not ,(rewrite-instruction self rule (second form) count-references)]
218 lookahead
219 `[not [not ,(rewrite-instruction self rule (second form) count-references)]]
220 loadarg
221 `[loadarg]
222 else
223 error "unhandled form" form
224 parse-memo-two-key rule-name stream frame-pointer stack-pointer
225 memo = self.two-key-memo
226 inputpos = stream.input-position
227 mark stream
228 ptr = get-ptr memo rule-name inputpos
229 if (== ptr 0)
230 result = (actual-parse self rule-name stream frame-pointer stack-pointer)
231 put-vals memo rule-name inputpos result stream.input-position
232 pop-mark stream
233 result
234 else
235 result = inline (deref ptr 0)
236 pos = inline (deref ptr CHURCH_WORD_SIZE)
237 if (not (eq? result o-fail))
238 reset-to stream pos
239 else
240 reset-to-mark stream
241 pop-mark stream
242 result
243 parse-memo rule-name stream frame-pointer stack-pointer
244 memo = self.memo-table
245 inputpos = stream.input-position
246 ; print "in parse-memo"
247 ; print memo
248 ; print inputpos
249 ; column = memo[inputpos]
250 column = unsafe-get-array-value memo inputpos
251 if (null? column)
252 ; print "making column"
253 ; print inputpos
254 column = make-array (* self.column-size 2) 4
255 ; memo[inputpos] = column
256 unsafe-set-array-value memo inputpos column
257 rule = get self.rules-map rule-name nil
258 ; assert rule "missing rule"
259 ; assert rule.rule-number "bad rule number"
260 ; print "lookup"
261 ; print column
262 ; print rule.rule-number
263 ; result = column[(* rule.rule-number 2)]
264 result = unsafe-get-array-value column (* rule.rule-number 2)
265 ; print result
266 if (null? result)
267 result = actual-parse self rule-name stream frame-pointer stack-pointer
268 ; column[(* rule.rule-number 2)] = result
269 unsafe-set-array-value column (* rule.rule-number 2) result
270 ; column[+ (* rule.rule-number 2) 1] = stream.input-position
271 unsafe-set-array-value column (+ (* rule.rule-number 2) 1) stream.input-position
272 result
273 else
274 ; reset-to stream column[+ (* rule.rule-number 2) 1]
275 reset-to stream (unsafe-get-array-value column (+ (* rule.rule-number 2) 1))
276 result
277 parse-memo-rule rule stream frame-pointer stack-pointer
278 memo = self.memo-table
279 inputpos = stream.input-position
280 column = unsafe-get-array-value memo inputpos
281 if (null? column)
282 column = make-array (* self.column-size 2) 4
283 unsafe-set-array-value memo inputpos column
284 result = unsafe-get-array-value column (* rule.rule-number 2)
285 if (null? result)
286 result = actual-parse-rule self rule stream frame-pointer stack-pointer
287 unsafe-set-array-value column (* rule.rule-number 2) result
288 unsafe-set-array-value column (+ (* rule.rule-number 2) 1) stream.input-position
289 result
290 else
291 reset-to stream (unsafe-get-array-value column (+ (* rule.rule-number 2) 1))
292 result
293 actual-parse rule-name stream frame-pointer stack-pointer
294 ; curr-rule = (if (null? self.current-rule) nil (unsafe-car self.current-rule))
295 ; self.current-rule = cons rule-name self.current-rule
296 ; cpm = self.call-profile-map
297 ; lookup1 = get cpm curr-rule nil
298 ; if (null? lookup1)
299 ; d = new 'dictionary
300 ; create d 10
301 ; put cpm curr-rule d
302 ; put d rule-name 1
303 ; else
304 ; d = lookup1
305 ; lookup2 = get d rule-name nil
306 ; if (null? lookup2)
307 ; put d rule-name 1
308 ; else
309 ; put d rule-name (+ lookup2 1)
310 lookup = get self.rules-map rule-name nil
311 if (null? lookup)
312 ; out "** primitive parse "
313 ; print rule-name
314 prim-result = apply rule-name self stream
315 ; self.current-rule = unsafe-cdr self.current-rule
316 prim-result
317 else
318 r = lookup
319 frame-pointer = stack-pointer
320 stack-pointer = + (+ stack-pointer r.variables-length) 1
321 loop
322 for i from frame-pointer to stack-pointer
323 do
324 self.data-stack[i] = nil
326 result = interpret self r.instructions stream frame-pointer stack-pointer
327 ; self.current-rule = unsafe-cdr self.current-rule
328 result
329 actual-parse-rule rule stream frame-pointer stack-pointer
330 r = rule
331 frame-pointer = stack-pointer
332 stack-pointer = + (+ stack-pointer r.variables-length) 1
333 loop
334 for i from frame-pointer to stack-pointer
335 do
336 self.data-stack[i] = nil
338 result = interpret self r.instructions stream frame-pointer stack-pointer
339 result
340 parse-with-arg rule-name stream frame-pointer stack-pointer arg
341 ; print "** parse with arg"
342 ; print rule-name
343 ; print arg
344 lookup = get self.rules-map rule-name nil
345 if (null? lookup)
346 ; error "primitive with arg" rule-name
347 apply rule-name self stream arg
348 else
349 r = lookup
350 frame-pointer = stack-pointer
351 stack-pointer = + (+ stack-pointer r.variables-length) 1
352 loop
353 for i from frame-pointer to stack-pointer
354 do
355 self.data-stack[i] = nil
357 self.data-stack[ frame-pointer ] = arg
358 interpret self r.instructions stream frame-pointer stack-pointer
359 seq stream arg
360 if (_o-fail? arg)
361 return-from seq o-fail
362 ; print "in seq"
363 ; print arg
364 mark stream
365 loop
366 for x in arg
367 do
368 str = x
369 ; print "seq str"
370 ; print str
371 ; print "next"
372 if (string? str)
373 print "is string"
374 error "not string" str
375 else
376 if (at-end? stream)
377 reset-to-mark stream
378 pop-mark stream
379 return-from seq o-fail
380 c = read-next stream
381 if (not (eq? c str))
382 reset-to-mark stream
383 pop-mark stream
384 return-from seq o-fail
386 pop-mark stream
387 ; print "in seq ret"
388 arg
389 anything stream
390 if (at-end? stream)
391 o-fail
392 else
393 read-next stream
394 cnewline stream
395 if (at-end? stream)
396 o-fail
397 else
398 c = peek stream
399 ; assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
400 x = nil
401 inline (set! |x| (|church-make-character| 10))
402 if (eq? c x)
403 read-next stream
404 else
405 unpeek stream
406 o-fail
407 stringquote stream
408 if (at-end? stream)
409 o-fail
410 else
411 c = peek stream
412 ; assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
413 x = nil
414 inline (set! |x| (|church-make-character| 34))
415 if (eq? c x)
416 read-next stream
417 else
418 unpeek stream
419 o-fail
420 digit stream
421 if (>= (remaining-byte-count stream) 1)
422 c = peek stream
423 ; assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
424 if (and (char? c) (digit? c))
425 read-next stream
426 c
427 else
428 unpeek stream
429 o-fail
430 else
431 o-fail
432 letter stream
433 if (>= (remaining-byte-count stream) 1)
434 c = peek stream
435 ; assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
436 if (and (char? c) (letter? c))
437 read-next stream
438 else
439 unpeek stream
440 o-fail
441 else
442 o-fail
443 interpret-action form frame-pointer stack-pointer quoting
444 ; print "interpret-action"
445 ; print form
446 ; print frame-pointer
447 typecase form
448 cons
449 if (eq? (unsafe-car form) 'quote)
450 second form
451 else
452 if (eq? (unsafe-car form) '_ometa_get_variable)
453 ; print "getting variable"
454 ; print (second form)
455 ; print self.data-stack[frame-pointer]
456 self.data-stack[+ frame-pointer (second form)]
457 else
458 collector = nil
459 loop
460 for x in form
461 do
462 if (and (cons? x) (eq? (unsafe-car x) '_ometa_get_variable_splice))
463 mylist = self.data-stack[+ frame-pointer (second x)]
464 collector = append! (reverse! mylist) collector
465 else
466 push (interpret-action self x frame-pointer stack-pointer quoting) collector
468 ; print collector
469 reverse! collector
470 else
471 error "bad type in interpret-action" form
472 interpret ins stream frame-pointer stack-pointer
473 ; record-trace stream.input-position ins
474 ; out "<-------- "
475 ; if (not (at-end? stream))
476 ; print (remaining stream)
477 ; print ins
478 ; print stream.input-position
479 ; print "stack-pointer"
480 ; print stack-pointer
481 ; print ">"
482 ; loop
483 ; for i from 0 to frame-pointer
484 ; do
485 ; print self.data-stack[i]
486 ;
487 ; print ">>"
488 ; loop
489 ; for i from frame-pointer to stack-pointer
490 ; do
491 ; print self.data-stack[i]
492 ;
493 ; pm = self.ins-profile-map
494 ; entry = get pm ins nil
495 ; if (null? entry)
496 ; put pm ins 1
497 ; else
498 ; put pm ins (+ 1 entry)
499 ; if self.tracing
500 ; print ins
501 case (unsafe-car ins)
502 match-char
503 if (>= (remaining-byte-count stream) 1)
504 arg = (unsafe-car (unsafe-cdr ins))
505 c = peek stream
506 ; assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
507 if (eq? c arg)
508 read-next stream
509 else
510 unpeek stream
511 o-fail
512 else
513 o-fail
514 app-rule (parse-memo-rule self (unsafe-car (unsafe-cdr ins)) stream frame-pointer stack-pointer)
515 app-rule-no-memo (actual-parse-rule self (unsafe-car (unsafe-cdr ins)) stream frame-pointer stack-pointer)
516 app (parse-memo self (unsafe-car (unsafe-cdr ins)) stream frame-pointer stack-pointer)
517 app-no-memo (actual-parse self (unsafe-car (unsafe-cdr ins)) stream frame-pointer stack-pointer)
518 and
519 args = unsafe-cdr ins
520 if (null? args)
521 true
522 else
523 mark stream
524 answer = nil
525 loop
526 for x in args
527 do (answer = interpret self x stream frame-pointer stack-pointer)
528 when (_o-fail? answer)
529 do
530 reset-to-mark stream
531 pop-mark stream
532 return-from interpret o-fail
534 pop-mark stream
535 answer
536 or
537 mark stream
538 args = unsafe-cdr ins
539 ; if (null? args)
540 ; error "bad or" ins
541 loop
542 for x in args
543 do
544 reset-to-mark stream
545 answer = interpret self x stream frame-pointer stack-pointer
546 if (not (_o-fail? answer))
547 pop-mark stream
548 return-from interpret answer
550 pop-mark stream
551 o-fail
552 many
553 answer = nil
554 loop
555 do
556 mark stream
557 v = interpret self (unsafe-car (unsafe-cdr ins)) stream frame-pointer stack-pointer
558 if (_o-fail? v)
559 reset-to-mark stream
560 pop-mark stream
561 return-from interpret (reverse! answer)
562 push v answer
563 pop-mark stream
565 many1
566 x = unsafe-car (unsafe-cdr ins)
567 v = interpret self x stream frame-pointer stack-pointer
568 if (_o-fail? v)
569 o-fail
570 else
571 answer = list v
572 loop
573 do
574 mark stream
575 v = interpret self x stream frame-pointer stack-pointer
576 if (_o-fail? v)
577 reset-to-mark stream
578 pop-mark stream
579 return-from interpret (reverse! answer)
580 push v answer
581 pop-mark stream
583 act
584 ; print "act"
585 ; print ins
586 v = interpret-action self (unsafe-car (unsafe-cdr ins)) frame-pointer stack-pointer nil
587 ; print "interpret-action "
588 ; print v
589 v
590 set
591 index = unsafe-car (unsafe-cdr ins)
592 x = unsafe-car (unsafe-cdr (unsafe-cdr ins))
593 v = interpret self x stream frame-pointer stack-pointer
594 self.data-stack[+ frame-pointer index] = v
595 v
596 not
597 mark stream
598 if (_o-fail? (interpret self (unsafe-car (unsafe-cdr ins)) stream frame-pointer stack-pointer))
599 pop-mark stream
600 true
601 else
602 reset-to-mark stream
603 pop-mark stream
604 o-fail
605 app-token
606 str = second ins
607 char-array = (unsafe-car (unsafe-cdr (unsafe-cdr ins)))
608 len = _unsafe-array-length char-array
609 if (>= (remaining-byte-count stream) len)
610 input-position = stream.input-position
611 native1 = char-array.native-array
612 native2 = stream.input-array.native-array
613 result = 0
614 inline (set! result (tf (call-c memcmp native1 (+ native2 (* (uf input-position) CHURCH_WORD_SIZE)) (* (uf len) CHURCH_WORD_SIZE))))
615 if (== result 0)
616 read-ahead stream len
617 ; print "app-token returning"
618 ; print str
619 str
620 else
621 ;print "app-token failed"
622 ;print (remaining stream)
623 o-fail
624 else
625 o-fail
626 app-with-nil
627 parse-with-arg self (unsafe-car (unsafe-cdr ins)) stream frame-pointer stack-pointer nil
628 app-with-argument
629 parse-with-arg self (unsafe-car (unsafe-cdr ins)) stream frame-pointer stack-pointer self.data-stack[ + frame-pointer (unsafe-car (unsafe-cdr (unsafe-cdr ins)))]
630 app-with-string
631 parse-with-arg self (unsafe-car (unsafe-cdr ins)) stream frame-pointer stack-pointer (unsafe-car (unsafe-cdr (unsafe-cdr ins)))
632 loadarg
633 self.data-stack[frame-pointer]
634 dispatch-on-char
635 if (>= (remaining-byte-count stream) 1)
636 dispatch-table = second ins
637 c = peek stream
638 ; rule = dispatch-table[(char-code c)]
639 rule = unsafe-get-array-value dispatch-table (char-code c)
640 unpeek stream
641 if (null? rule)
642 o-fail
643 else
644 interpret self rule stream frame-pointer stack-pointer
645 else
646 o-fail
647 else
648 error "invalid ins" ins
650 global trace-table
652 record-trace position ins
653 entry = get trace-table ins nil
654 put trace-table ins (cons ins entry)
656 show-trace
657 keys = keys trace-table
658 total = 0
659 loop
660 for k in keys
661 do
662 total = + total (length (get trace-table k nil))
664 out "total is "
665 print total