Permalink
Browse files

Seems correct now. The problem was exps vs. exp in free.

  • Loading branch information...
1 parent f254a11 commit 3ba8dd2fd3357a4414c7b864ed233daa5fc25923 J. Ian Johnson committed Oct 8, 2012
Showing with 517 additions and 528 deletions.
  1. +71 −68 abstract.rkt
  2. +4 −1 check.rkt
  3. +18 −22 contour.rkt
  4. +2 −2 data.rkt
  5. +10 −4 drivers.rkt
  6. +4 −2 env.rkt
  7. +323 −337 flow.rkt
  8. +13 −17 free.rkt
  9. +16 −21 library.rkt
  10. +13 −4 macros.rkt
  11. +5 −5 ordset-list.rkt
  12. +38 −45 parse.rkt
View
@@ -155,29 +155,33 @@
(define aval
(lambda (kind l . args)
- (let* ((l (if (or (eq? Const-split #t)
- (and (pair? Const-split) (memq kind Const-split))
- (not (null? args))
- (eq? kind 'prim))
- l
- 0))
- (key `(,kind ,@args))
- (r (assoc key (vector-ref aval-hash-table l))))
- (if r
- (cdr r)
- (let ((v `(,kind ,l ,@args))
- (n n-avals))
- (when (= n (vector-length aval-table))
- (let ((x (vector-tabulate
- (* 2 n)
- (lambda (i)
- (if (< i n) (vector-ref aval-table i) 0)))))
- (set! aval-table x)))
- (vector-set! aval-table n v)
- (vector-set! aval-hash-table l
- (cons (cons key n) (vector-ref aval-hash-table l)))
- (set! n-avals (+ 1 n-avals))
- n)))))
+ (define l*
+ (cond [(or (eq? Const-split #t)
+ (and (pair? Const-split) (memq kind Const-split))
+ (not (null? args))
+ (eq? kind 'prim))
+ l]
+ [else 0]))
+ (define key `(,kind ,@args))
+ (define r (assoc key (vector-ref aval-hash-table l*)))
+ (cond [r (cdr r)]
+ [else
+ (define v `(,kind ,l* ,@args))
+ (define n n-avals)
+ ;; Grow the vector if it needs space.
+ (when (= n (vector-length aval-table))
+ (define x
+ (vector-tabulate
+ (* 2 n)
+ (lambda (i)
+ (if (< i n) (vector-ref aval-table i) 0))))
+ (set! aval-table x))
+ (vector-set! aval-table n v)
+ (vector-set! aval-hash-table l*
+ (cons (cons key n)
+ (vector-ref aval-hash-table l*)))
+ (set! n-avals (+ 1 n-avals))
+ n])))
(set-aval-kind! (lambda (n) (car (vector-ref aval-table n))))
(set-aval-label! (lambda (n) (cadr (vector-ref aval-table n))))
@@ -298,7 +302,7 @@
(if (or (not (intset-empty? (Point-old p)))
(not (intset-empty? (Point-new p))))
(action)
- (p-> p (let ((first #t))
+ (p-> p (let ([first #t])
(lambda (new)
(when first
(set! first #f)
@@ -332,44 +336,39 @@
(lambda ()
(let loop ()
(unless (zero? (queue-size work-q))
- (let* ([p (queue-pop! work-q)]
- [new (Point-new p)])
- (set-Point-old! p (intset-union (Point-old p) new))
- (set-Point-new! p (intset-make-empty))
- (for-each
- (lambda (succ) (succ new))
- (Point-succ p))
- (loop))))))
+ (define p (queue-pop! work-q))
+ (define new (Point-new p))
+ (set-Point-old! p (intset-union (Point-old p) new))
+ (set-Point-new! p (intset-make-empty))
+ (for ([succ (in-list (Point-succ p))]) (succ new))
+ (loop)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Printing
(define print-aval
(let ((penv (match-lambda [(cons n k) `(,(Name-name n) -> ,k)])))
(lambda (x)
- (let ((kind (aval-kind x))
- (l (aval-label x)))
- (cond [(aval-is-simple? x)
- `(,kind ,l)]
- [(memq kind '(closure))
- `(,kind ,l
- ,(print-contour (aval-contour x))
- ,(map penv (aval-env x)))]
- [else
- `(,kind ,l
- ,(print-contour (aval-contour x))
- ,@(map (lambda (f)
- (cons
- (let ([l (Point-label f)])
- (if (Name? l)
- (Name-name l)
- l))
- (Point-contour f)))
- (aval-fields x)))])))))
+ (define kind (aval-kind x))
+ (define l (aval-label x))
+ (cond [(aval-is-simple? x)
+ `(,kind ,l)]
+ [(memq kind '(closure))
+ `(,kind ,l
+ ,(print-contour (aval-contour x))
+ ,(map penv (aval-env x)))]
+ [else
+ `(,kind ,l
+ ,(print-contour (aval-contour x))
+ ,@(for/list ([f (in-list (aval-fields x))])
+ (define l (Point-label f))
+ (cons (cond [(Name? l) (Name-name l)]
+ [else l])
+ (Point-contour f))))]))))
(define print-point
(lambda (a)
- (map print-aval (intset->list (point-elements a)))))
+ (map print-aval a)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Statistics
@@ -378,16 +377,16 @@
(set-print-abstract-statistics!!
(lambda ()
- (let* ([size (lambda (p) (intset-size (point-elements p)))]
- [n (+ (for*/sum ([v (in-list variables)]
+ (define size (lambda (p) (intset-size (point-elements p))))
+ (define n (+ (for*/sum ([v (in-list variables)]
[p (in-list (points-at-var v))])
(size p))
(for*/sum ([l (in-range n-labels)]
- [p (in-list (points-at-label l))])
- (size p)))])
- (printf "; ~a program points, ~a distinct values, ~a values in the graph~%"
- n-points n-avals n)
- (printf "; ~a entries in call map~%" (total-call-map-size)))))
+ [p (in-list (points-at-label l))])
+ (size p))))
+ (printf "; ~a program points, ~a distinct values, ~a values in the graph~%"
+ n-points n-avals n)
+ (printf "; ~a entries in call map~%" (total-call-map-size))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ALL OLD AND POSSIBLY OUT OF DATE
@@ -501,16 +500,20 @@
((zero? (list-ref dist n)) (loop (- n 1) acc))
(else (loop (- n 1) (cons `(,n : ,(list-ref dist n)) acc))))))))
+(define (max-list lst)
+ (for/fold ([acc 0]) ([x (in-list lst)])
+ (max acc x)))
+
(define h-union-counts
(lambda ()
- (let* ((counts (reverse union-counts))
- (max-count (foldl max 0 counts)))
- (histogram
- (map (lambda (x)
- (if (negative? x)
- (- max-count)
- x))
- counts)))))
+ (define counts (reverse union-counts))
+ (define max-count (max-list counts))
+ (histogram
+ (map (lambda (x)
+ (if (negative? x)
+ (- max-count)
+ x))
+ counts))))
(define histogram
(lambda (dist)
@@ -521,7 +524,7 @@
(cons x acc)))
'()
dist))
- (max-count (foldl max 0 counts)))
+ (max-count (max-list counts)))
(printf "X-axis 0:~a, Y-axis 0:~a~n" (length counts) max-count)
(make-histogram
intset-version
View
@@ -93,7 +93,10 @@
(let ([doit (lambda ()
(match-let ([(cons defs n-checks) (check-summary unbound)])
(for ([def (in-list defs)])
- (printf "~a~%~%" def))
+ (define b
+ (with-output-to-bytes (λ () (pretty-print def))))
+ ;; remove the first '
+ (write-bytes (subbytes b 1)))
n-checks))])
(if (string? file)
(begin
View
@@ -162,17 +162,18 @@
(define old-poly-var-split
(lambda (x aenv l k let-label recursive? component)
(let ([p (index-result-map l k)]
- [make-contour (if recursive?
- (let ([c (context->contour k)])
- (lambda (vk) (old-rec-contour vk let-label c)))
- (lambda (vk) (old-var-contour vk let-label l)))])
+ [make-contour
+ (cond [recursive?
+ (define c (context->contour k))
+ (lambda (vk) (old-rec-contour vk let-label c))]
+ [else (lambda (vk) (old-var-contour vk let-label l))])])
(p-> (index-var-map x (lookup aenv x))
(lambda (new) (p+avals p (split new make-contour))))
p)))
(define old-poly-let-binding-contour
(lambda (k l)
- (let ((n (vector-length k)))
+ (let ([n (vector-length k)])
(vector-tabulate
(+ 1 n)
(lambda (i)
@@ -181,8 +182,7 @@
l))))))
(define poly-call-site-contour
- (lambda (l k vk)
- vk))
+ (lambda (l k vk) vk))
;;;;;;;;;;;;;;;;
;; Type based splitting
@@ -294,10 +294,9 @@
(vector-tabulate
(vector-length k)
(lambda (i)
- (let ((l (vector-ref k i)))
- (if (= l old-l)
- (vector-ref current-k i)
- l))))))
+ (define l (vector-ref k i))
+ (cond [(= l old-l) (vector-ref current-k i)]
+ [else l])))))
;; Build a new contour at a variable reference.
(define max-contour 4000)
@@ -307,9 +306,8 @@
(vector-tabulate
(min (+ 1 n) max-contour)
(lambda (i)
- (if (zero? i)
- l
- (vector-ref k (- i 1))))))))
+ (cond [(zero? i) l]
+ [else (vector-ref k (- i 1))]))))))
;; Build a new contour at a recursive variable reference.
(define rec-contour
@@ -325,9 +323,8 @@
(vector-tabulate
(min Call (+ 1 (vector-length k)))
(lambda (i)
- (if (zero? i)
- l
- (vector-ref k (- i 1)))))))
+ (cond [(zero? i) l]
+ [else (vector-ref k (- i 1))])))))
;; Build a new if contour.
(define if-contour
@@ -392,11 +389,10 @@
;
-(define (false? e) (eq? e #f))
-(define (true? e) (cond ((list? e)
- (if (not (null? e))
- #t #f))
- (else e)))
+(define false? not)
+(define (true? e)
+ (cond [(list? e) (not (null? e))]
+ [else e]))
(define (make-cont-based-contour v)
(let* ([env (aval-env v)]
View
@@ -65,15 +65,15 @@
(struct Begin (exps) #:prefab)
(struct Const (val) #:prefab)
(struct If (test then else) #:prefab)
-(struct Lam (names exp [free #:auto #:mutable]) #:prefab)
+(struct Lam (names exp [free #:auto #:mutable]) #:prefab #:auto-value #f)
(struct Let (bindings exp) #:prefab)
(struct Clet (names bindings exp) #:prefab)
(struct Letr (bindings exp) #:prefab)
(struct Or (exps) #:prefab)
(struct Set! (name exp) #:prefab)
(struct Var (name) #:prefab)
-(struct Vlam (names rest exp [free #:auto #:mutable]) #:prefab)
+(struct Vlam (names rest exp [free #:auto #:mutable]) #:prefab #:auto-value #f)
(struct Letcc (name exp) #:prefab)
(define-match-expander Lam:
View
@@ -60,7 +60,8 @@
[before-analysis (current-inexact-milliseconds)]
[print-warnings (analyse)]
[before-opt (current-inexact-milliseconds)]
- [_ (begin (optimization))]
+ [_ (begin (printf "Finished analysis.~%")
+ (optimization))]
[before-output (current-inexact-milliseconds)]
[result (output unbound)]
[before-end (current-inexact-milliseconds)])
@@ -211,7 +212,8 @@
(printf "Loading slow CHECKs...~%")
(load "checklib.scm")
(set! loaded-checks 'slow))
- (load file)
+ (printf "I would run ~a, but...~%" file)
+ ;;(load file)
#;
(parameterize ([read-accept-reader #t])
(define expr (compile (with-input-from-file file read-syntax)))
@@ -297,7 +299,10 @@
(define inline-output
(lambda (file unbound tree)
(let ([doit (lambda ()
- (for-each pretty-write (pexprs-with-checks tree)))])
+ (for ([e (in-list (pexprs-with-checks tree))])
+ (define b
+ (with-output-to-bytes (λ () (pretty-print e))))
+ (write-bytes (write-bytes (subbytes b 1)))))])
(if (string? file)
(begin
(with-output-to-file file
@@ -375,4 +380,5 @@
(check-output output-file unbound)])
(void))))))
-(cf: "/home/ianj/projects/polymorphic-splitting/boyer.scm")
+;;(cf: "/home/ianj/papers/boyer.scm")
+(cf: "church.scm")
View
@@ -7,7 +7,9 @@
(provide empty-env empty-env?
lookup lookup? bound? extend-env extend-env*
- join-env env->list env-domain env-range env-restrict env-map
+ join-env env->list env-domain env-range
+ env-restrict
+ env-map
filter-env)
(define empty-env '())
@@ -17,7 +19,7 @@
(define lookup
(lambda (env x)
(match (assq x env)
- [#f (error 'lookup "no binding for ~s" x)]
+ [#f (error 'lookup "no binding for ~s (~a)" x env)]
[(cons _ b) b])))
(define lookup?
Oops, something went wrong.

0 comments on commit 3ba8dd2

Please sign in to comment.