377 lines
15 KiB
Scheme
377 lines
15 KiB
Scheme
|
|
(module mc mzscheme
|
|
(require (lib "reduction-semantics.ss" "reduction-semantics")
|
|
(lib "generator.ss" "reduction-semantics")
|
|
(prefix matcher: (lib "matcher.ss" "reduction-semantics" "private"))
|
|
(lib "list.ss")
|
|
(lib "class.ss")
|
|
(lib "mred.ss" "mred"))
|
|
|
|
(provide build-reductions
|
|
generation-depth
|
|
reduction-depth
|
|
generate-and-test
|
|
(struct reduction-graph (initial ht)))
|
|
|
|
;; reduction-graph = (make-graph sexp hash-table[sexp -o> (listof sexp)])
|
|
(define-struct reduction-graph (initial ht))
|
|
|
|
(define generation-depth (make-parameter 2))
|
|
(define reduction-depth (make-parameter 10))
|
|
(define max-queue-size 100)
|
|
|
|
;; computes all of the terms of size `n' or smaller for each non-terminal
|
|
;; in the language
|
|
;; [ sizes are limited by number of recusive constructions of each non terminal;
|
|
;; 4 is huge for even tiny languages ]
|
|
(define (generate-and-test lang nt reductions reductions-test)
|
|
|
|
(define frame (make-object frame% "Status"))
|
|
(define gc-on-bitmap (make-object bitmap% (build-path (collection-path "icons") "recycle.gif")))
|
|
(define gc-off-bitmap (make-object bitmap%
|
|
(send gc-on-bitmap get-width)
|
|
(send gc-on-bitmap get-height)
|
|
#t))
|
|
(define stupid-internal-define-syntax1
|
|
(let ([bdc (make-object bitmap-dc% gc-off-bitmap)])
|
|
(send bdc clear)
|
|
(send bdc set-bitmap #f)))
|
|
|
|
(define-values (reductions-queue-size-message
|
|
total-reductions-message
|
|
test-queue-size-message
|
|
total-tests-message
|
|
memory-allocated-message)
|
|
(let* ([outer-hp (make-object horizontal-panel% frame)]
|
|
[outer-vp (make-object vertical-panel% outer-hp)]
|
|
[hp1 (make-object horizontal-panel% outer-vp)]
|
|
[hp2 (make-object horizontal-panel% outer-vp)]
|
|
[hp3 (make-object horizontal-panel% outer-vp)]
|
|
[hp4 (make-object horizontal-panel% outer-vp)]
|
|
[hp5 (make-object horizontal-panel% outer-vp)]
|
|
[l1 (make-object message% "To Reduce: " hp1)]
|
|
[l2 (make-object message% "Total Expressions: " hp2)]
|
|
[l3 (make-object message% "To Test: " hp3)]
|
|
[l4 (make-object message% "Total Tests: " hp4)]
|
|
[l5 (make-object message% "Megabytes Allocated: " hp5)]
|
|
[gc-canvas (instantiate canvas% ()
|
|
(parent outer-hp)
|
|
(stretchable-width #f)
|
|
(stretchable-height #f)
|
|
(min-width (send gc-on-bitmap get-width))
|
|
(min-height (send gc-on-bitmap get-height)))]
|
|
[dms-button (instantiate button% ("DMS" outer-hp)
|
|
[callback (lambda (b e)
|
|
(dump-memory-stats '<struct>))])])
|
|
|
|
(register-collecting-blit gc-canvas
|
|
0
|
|
0
|
|
(send gc-on-bitmap get-width)
|
|
(send gc-on-bitmap get-height)
|
|
gc-on-bitmap
|
|
gc-off-bitmap)
|
|
(let ([w (max (send l1 get-width)
|
|
(send l2 get-width)
|
|
(send l3 get-width)
|
|
(send l4 get-width)
|
|
(send l5 get-width))])
|
|
(send l1 min-width w)
|
|
(send l2 min-width w)
|
|
(send l3 min-width w)
|
|
(send l4 min-width w)
|
|
(send l5 min-width w))
|
|
|
|
(values
|
|
(instantiate message% ()
|
|
(label "0000000")
|
|
;(stretchable-width #t)
|
|
(parent hp1))
|
|
(instantiate message% ()
|
|
(label "0000000")
|
|
;(stretchable-width #t)
|
|
(parent hp2))
|
|
(instantiate message% ()
|
|
(label "0000000")
|
|
;(stretchable-width #t)
|
|
(parent hp3))
|
|
(instantiate message% ()
|
|
(label "0000000")
|
|
;(stretchable-width #t)
|
|
(parent hp4))
|
|
(instantiate message% ()
|
|
(label "0000000")
|
|
;(stretchable-width #t)
|
|
(parent hp5)))))
|
|
|
|
(define go (make-semaphore 0))
|
|
|
|
(define no-more-terms (box 'no-more-terms))
|
|
|
|
(define generation-thread
|
|
(thread
|
|
(lambda ()
|
|
(semaphore-wait go)
|
|
(generate lang nt enqueue-for-reduction-thread)
|
|
(enqueue-for-reduction-thread no-more-terms))))
|
|
|
|
(define total-reductions 0)
|
|
(define reduction-queue (new-queue))
|
|
(define reduction-queue-sema (make-semaphore 1))
|
|
(define reduction-thread-sema (make-semaphore 0))
|
|
(define reduction-producer-sema (make-semaphore max-queue-size))
|
|
(define (enqueue-for-reduction-thread sexp)
|
|
(semaphore-wait reduction-producer-sema)
|
|
(semaphore-wait reduction-queue-sema)
|
|
(enqueue reduction-queue sexp)
|
|
(set! total-reductions (+ total-reductions 1))
|
|
(semaphore-post reduction-thread-sema)
|
|
(semaphore-post reduction-queue-sema))
|
|
|
|
(define reduction-thread
|
|
(thread
|
|
(lambda ()
|
|
(semaphore-wait go)
|
|
(let loop ()
|
|
(semaphore-wait reduction-thread-sema)
|
|
(semaphore-wait reduction-queue-sema)
|
|
(let ([sexp (dequeue reduction-queue)])
|
|
(semaphore-post reduction-queue-sema)
|
|
(semaphore-post reduction-producer-sema)
|
|
(cond
|
|
[(eq? sexp no-more-terms)
|
|
(enqueue-for-test-thread no-more-terms)]
|
|
[else
|
|
(enqueue-for-test-thread (build-reductions sexp reductions))
|
|
(loop)]))))))
|
|
|
|
(define total-tests 0)
|
|
(define test-queue (new-queue))
|
|
(define test-queue-sema (make-semaphore 1))
|
|
(define test-thread-sema (make-semaphore 0))
|
|
(define test-producer-sema (make-semaphore max-queue-size))
|
|
(define (enqueue-for-test-thread sexp)
|
|
(semaphore-wait test-producer-sema)
|
|
(semaphore-wait test-queue-sema)
|
|
(enqueue test-queue sexp)
|
|
(set! total-tests (+ total-tests 1))
|
|
(semaphore-post test-thread-sema)
|
|
(semaphore-post test-queue-sema))
|
|
|
|
(define test-thread
|
|
(thread
|
|
(lambda ()
|
|
(semaphore-wait go)
|
|
(let loop ()
|
|
(semaphore-wait test-thread-sema)
|
|
(semaphore-wait test-queue-sema)
|
|
(let ([reds (dequeue test-queue)])
|
|
(semaphore-post test-queue-sema)
|
|
(semaphore-post test-producer-sema)
|
|
(cond
|
|
[(eq? reds no-more-terms)
|
|
(semaphore-post done-semaphore)]
|
|
[else
|
|
(reductions-test reds)]))
|
|
(loop)))))
|
|
|
|
(define mem-divisor (* 1024 1024))
|
|
(define (update-status)
|
|
(send test-queue-size-message set-label (format "~a" (queue-size test-queue)))
|
|
(send total-tests-message set-label (format "~a" total-tests))
|
|
(send reductions-queue-size-message set-label (format "~a" (queue-size reduction-queue)))
|
|
(send total-reductions-message set-label (format "~a" total-reductions))
|
|
(send memory-allocated-message set-label (number->string (quotient (current-memory-use) mem-divisor))))
|
|
|
|
(define status-thread
|
|
(thread
|
|
(lambda ()
|
|
(semaphore-wait go)
|
|
(with-handlers ([exn:break? (lambda (x) (semaphore-post status-thread-done))])
|
|
(let loop ()
|
|
(update-status)
|
|
(sleep 2)
|
|
(loop))))))
|
|
|
|
(define done-semaphore (make-semaphore 0))
|
|
(define status-thread-done (make-semaphore 0))
|
|
|
|
(send frame show #t)
|
|
(semaphore-post go)
|
|
(semaphore-post go)
|
|
(semaphore-post go)
|
|
(semaphore-post go)
|
|
(yield done-semaphore)
|
|
(break-thread status-thread)
|
|
(semaphore-wait status-thread-done)
|
|
(update-status)
|
|
(make-object message% "Done." frame))
|
|
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ;
|
|
; ; ;
|
|
; ; ; ;
|
|
; ; ;; ;;; ;;; ; ; ; ;;;; ;;;; ; ;;;; ; ;;; ;;; ; ; ;; ;;; ; ;;; ; ;;;
|
|
; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ;; ; ; ;; ; ;; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ;; ; ; ;
|
|
; ; ;;;; ;;; ; ;;; ; ;;;; ;; ; ;;;; ; ; ;;; ; ; ;;;;; ; ;;; ; ;
|
|
; ; ;
|
|
; ; ; ;
|
|
; ;;;; ;
|
|
|
|
|
|
;; build-reductions : sexp (listof reductions) -> reduction-graph
|
|
;; builds the reduction graph for expression according to reductions
|
|
(define (build-reductions expression reductions)
|
|
(let* ([ht (make-hash-table 'equal)]
|
|
[reduce/add
|
|
(lambda (term)
|
|
(let ([reduced (reduce reductions term)])
|
|
(hash-table-put! ht term reduced)
|
|
(filter (lambda (term)
|
|
(not (hash-table-get ht term (lambda () #f))))
|
|
reduced)))])
|
|
(let loop ([frontier (list expression)]
|
|
[depth (reduction-depth)])
|
|
(unless (zero? depth)
|
|
(let* ([new-terms (apply append (map reduce/add frontier))])
|
|
(cond
|
|
[(null? new-terms) (void)]
|
|
[else
|
|
(loop new-terms (- depth 1))]))))
|
|
(make-reduction-graph expression ht)))
|
|
|
|
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;
|
|
;
|
|
; ;
|
|
; ;;; ; ;;; ; ;;; ;;; ; ;; ;;; ;;;; ; ;;;; ; ;;;
|
|
; ; ;; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ;; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ;;;;; ; ; ;;;;; ; ;;;; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ; ;;;; ; ; ;;;; ; ;;;;; ;; ; ;;;; ; ;
|
|
; ;
|
|
; ; ;
|
|
; ;;;;
|
|
|
|
|
|
|
|
;; generate : lang sexp (sexp -> void) -> void
|
|
;; generates the terms up to (generation-depth) in size
|
|
;; passes each that comes from gdesired-nt to enqueue-for-reduction-thread
|
|
(define (generate lang desired-nt enqueue-for-reduction-thread)
|
|
(let ([gens (lang->generator-table lang
|
|
'(0 1)
|
|
'(x y)
|
|
'("a" "b")
|
|
null
|
|
0)])
|
|
(let loop ([n 0])
|
|
(unless (n . > . (generation-depth))
|
|
(for-each-generated/size (lambda (sexp size)
|
|
(enqueue-for-reduction-thread sexp))
|
|
gens
|
|
n n desired-nt)
|
|
(loop (add1 n))))))
|
|
|
|
|
|
;; find-interesting-nts : (listof nt) sym -> (listof sym)
|
|
(define (find-interesting-nts clang desired-nt)
|
|
(let* ([lang (matcher:compiled-lang-lang clang)]
|
|
[ht (make-hash-table)]
|
|
[nt-syms (map matcher:nt-name lang)])
|
|
(let loop ([nt-sym desired-nt])
|
|
(let ([nt-lst (filter (lambda (x) (eq? (matcher:nt-name x) nt-sym)) lang)])
|
|
(cond
|
|
[(null? nt-lst) (void)]
|
|
[(null? (cdr nt-lst))
|
|
(let ([referenced-nt-syms (get-referenced-nts nt-syms (car nt-lst) lang)])
|
|
(for-each
|
|
(lambda (referenced-nt-sym)
|
|
(unless (hash-table-get ht referenced-nt-sym (lambda () #f))
|
|
(hash-table-put! ht referenced-nt-sym #t)
|
|
(loop referenced-nt-sym)))
|
|
referenced-nt-syms))]
|
|
[else (error 'mc.ss "found more than one definition of ~s in grammar" nt-sym)])))
|
|
(hash-table-map ht (lambda (x y) x))))
|
|
|
|
(define (get-referenced-nts nt-syms nt lang)
|
|
(let loop ([rhss (matcher:nt-rhs nt)]
|
|
[refd-nts null])
|
|
(cond
|
|
[(null? rhss) refd-nts]
|
|
[else (loop (cdr rhss)
|
|
(get-referenced-nts/rhs nt-syms (car rhss) refd-nts))])))
|
|
|
|
(define (get-referenced-nts/rhs nt-syms rhs acc)
|
|
(let loop ([pat (matcher:rhs-pattern rhs)]
|
|
[acc acc])
|
|
(cond
|
|
[(null? pat) acc]
|
|
[(pair? pat) (loop (car pat) (loop (cdr pat) acc))]
|
|
[(symbol? pat)
|
|
(if (memq pat nt-syms)
|
|
(cons pat acc)
|
|
acc)])))
|
|
|
|
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;;; ; ; ; ;;; ; ; ;;;
|
|
; ; ;; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ;;;;; ; ; ;;;;;
|
|
; ; ; ; ; ; ; ; ;
|
|
; ; ;; ; ;; ; ; ;; ;
|
|
; ;;; ; ;;; ; ;;;; ;;; ; ;;;;
|
|
; ;
|
|
; ;
|
|
; ;
|
|
|
|
|
|
|
|
(define-struct queue (hd tl size))
|
|
(define (new-queue) (make-queue null null 0))
|
|
(define (enqueue queue thnk)
|
|
(set-queue-size! queue (+ (queue-size queue) 1))
|
|
(let ([new-tail (cons thnk null)])
|
|
(if (null? (queue-hd queue))
|
|
(begin
|
|
(set-queue-hd! queue new-tail)
|
|
(set-queue-tl! queue new-tail))
|
|
(begin
|
|
(set-cdr! (queue-tl queue) new-tail)
|
|
(set-queue-tl! queue new-tail)))))
|
|
(define (dequeue queue)
|
|
(when (null? (queue-hd queue))
|
|
(error 'dequeue))
|
|
(set-queue-size! queue (- (queue-size queue) 1))
|
|
(let* ([qh (queue-hd queue)]
|
|
[fst (car qh)])
|
|
(set-queue-hd! queue (cdr qh))
|
|
(set-cdr! qh #f)
|
|
(when (null? (queue-hd queue))
|
|
(set-queue-tl! queue null))
|
|
fst))
|
|
(define (queue-empty? queue) (null? (queue-hd queue))))
|