suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix compiler/zo-marshal

Browse Source 
Missed some updates for recent local-type changes. Also, fix up a
few field names in the demodularizer.

original commit: d7eddb91ef
This commit is contained in:
Matthew Flatt 2012-11-15 05:21:42 -07:00
parent d003549257
commit bbc7d243e9
3 changed files with 33 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/compiler/demodularizer/gc-toplevels.rkt
View File

@ -138,7 +138,7 @@
(build-graph! lhs args-expr)] (build-graph! lhs args-expr)]
[(and f (struct primval (id))) [(and f (struct primval (id)))
(void)] (void)]
[(and f (struct localref (unbox? pos clear? other-clears? flonum?))) [(and f (struct localref (unbox? pos clear? other-clears? type)))
(void)] (void)]
[(and v (not (? form?))) [(and v (not (? form?)))
(void)])) (void)]))
@ -223,8 +223,8 @@
[(and cl (struct case-lam (name clauses))) [(and cl (struct case-lam (name clauses)))
(struct-copy case-lam cl (struct-copy case-lam cl
[clauses (map update clauses)])] [clauses (map update clauses)])]
[(struct let-one (rhs body flonum? unused?)) [(struct let-one (rhs body type unused?))
(make-let-one (update rhs) (update body) flonum? unused?)] ; Q: is flonum? okay here? (make-let-one (update rhs) (update body) type unused?)]
[(and f (struct let-void (count boxes? body))) [(and f (struct let-void (count boxes? body)))
(struct-copy let-void f (struct-copy let-void f
[body (update body)])] [body (update body)])]
@ -271,7 +271,7 @@
(update args-expr))] (update args-expr))]
[(and f (struct primval (id))) [(and f (struct primval (id)))
f] f]
[(and f (struct localref (unbox? pos clear? other-clears? flonum?))) [(and f (struct localref (unbox? pos clear? other-clears? type)))
f] f]
[(and v (not (? form?))) [(and v (not (? form?)))
v] v]

6
collects/compiler/demodularizer/update-toplevels.rkt
View File

@ -37,8 +37,8 @@
(map update clauses)) (map update clauses))
(struct-copy case-lam cl (struct-copy case-lam cl
[clauses new-clauses])] [clauses new-clauses])]
[(struct let-one (rhs body flonum? unused?)) [(struct let-one (rhs body type unused?))
(make-let-one (update rhs) (update body) flonum? unused?)] ; Q: is it okay to just pass in the old value for flonum? (make-let-one (update rhs) (update body) type unused?)]
[(and f (struct let-void (count boxes? body))) [(and f (struct let-void (count boxes? body)))
(struct-copy let-void f (struct-copy let-void f
[body (update body)])] [body (update body)])]
@ -85,7 +85,7 @@
(update args-expr))] (update args-expr))]
[(and f (struct primval (id))) [(and f (struct primval (id)))
f] f]
[(and f (struct localref (unbox? pos clear? other-clears? flonum?))) [(and f (struct localref (unbox? pos clear? other-clears? type)))
f] f]
[(and f (not (? form?))) [(and f (not (? form?)))
f] f]

41
collects/compiler/zo-marshal.rkt
View File

@ -317,7 +317,7 @@
CPT_VECTOR CPT_VECTOR
CPT_HASH_TABLE CPT_HASH_TABLE
CPT_STX CPT_STX
CPT_LET_ONE_FLONUM CPT_LET_ONE_TYPED
CPT_MARSHALLED CPT_MARSHALLED
CPT_QUOTE CPT_QUOTE
CPT_REFERENCE CPT_REFERENCE
@ -370,6 +370,7 @@
(define CLOS_SINGLE_RESULT 32) (define CLOS_SINGLE_RESULT 32)
(define BITS_PER_MZSHORT 32) (define BITS_PER_MZSHORT 32)
(define BITS_PER_ARG 4)
(define (int->bytes x) (define (int->bytes x)
(integer->integer-bytes x (integer->integer-bytes x
@ -579,6 +580,12 @@
(with-continuation-mark 'zo (typeof v) (with-continuation-mark 'zo (typeof v)
(begin0 (begin body ...) (void)))])) (begin0 (begin body ...) (void)))]))
(define (type->index type)
(case type
[(flonum) 1]
[(fixnum) 2]
[else (error 'type->index "unknown type: ~e" type)]))
(define (out-anything v out) (define (out-anything v out)
(with-type-trace v (with-type-trace v
(out-shared (out-shared
@ -742,9 +749,7 @@
(out-number (cond (out-number (cond
[clear? 1] [clear? 1]
[other-clears? 2] [other-clears? 2]
[else (+ 2 (case type [else (+ 2 (type->index type))])
[(flonum) 1]
[(fixnum) 2]))])
out)))))] out)))))]
[(? lam?) [(? lam?)
(out-lam v out)] (out-lam v out)]
@ -753,14 +758,16 @@
(cons (or name null) (cons (or name null)
lams) lams)
out)] out)]
[(struct let-one (rhs body flonum? unused?)) [(struct let-one (rhs body type unused?))
(out-byte (cond (out-byte (cond
[flonum? CPT_LET_ONE_FLONUM] [type CPT_LET_ONE_TYPED]
[unused? CPT_LET_ONE_UNUSED] [unused? CPT_LET_ONE_UNUSED]
[else CPT_LET_ONE]) [else CPT_LET_ONE])
out) out)
(out-anything (protect-quote rhs) out) (out-anything (protect-quote rhs) out)
(out-anything (protect-quote body) out)] (out-anything (protect-quote body) out)
(when type
(out-number (type->index type) out))]
[(struct let-void (count boxes? body)) [(struct let-void (count boxes? body))
(out-marshaled let-void-type-num (out-marshaled let-void-type-num
(list* (list*
@ -1099,8 +1106,8 @@
(match expr (match expr
[(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body)) [(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body))
(let* ([l (protect-quote body)] (let* ([l (protect-quote body)]
[any-refs? (or (ormap (lambda (t) (memq t '(ref flonum))) param-types) [any-refs? (or (not (andmap (lambda (t) (eq? t 'val)) param-types))
(ormap (lambda (t) (memq t '(flonum))) closure-types))] (not (andmap (lambda (t) (eq? t 'val/ref)) closure-types)))]
[num-all-params (if (and rest? (not (memq 'only-rest-arg-not-used flags))) [num-all-params (if (and rest? (not (memq 'only-rest-arg-not-used flags)))
(add1 num-params) (add1 num-params)
num-params)] num-params)]
@ -1109,22 +1116,26 @@
(append (append
(vector->list closure-map) (vector->list closure-map)
(let* ([v (make-vector (ceiling (let* ([v (make-vector (ceiling
(/ (* 2 (+ num-params (vector-length closure-map))) (/ (* BITS_PER_ARG (+ num-params (vector-length closure-map)))
BITS_PER_MZSHORT)))] BITS_PER_MZSHORT)))]
[set-bit! (lambda (i bit) [set-bit! (lambda (i bit)
(let ([pos (quotient (* 2 i) BITS_PER_MZSHORT)]) (let ([pos (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)])
(vector-set! v pos (vector-set! v pos
(bitwise-ior (vector-ref v pos) (bitwise-ior (vector-ref v pos)
(arithmetic-shift (arithmetic-shift
bit bit
(modulo (* 2 i) BITS_PER_MZSHORT))))))]) (modulo (* BITS_PER_ARG i) BITS_PER_MZSHORT))))))])
(for ([t (in-list param-types)] (for ([t (in-list param-types)]
[i (in-naturals)]) [i (in-naturals)])
(when (eq? t 'ref) (set-bit! i 1)) (case t
(when (eq? t 'flonum) (set-bit! i 2))) [(val) (void)]
[(ref) (set-bit! i 1)]
[else (set-bit! i (+ 1 (type->index t)))]))
(for ([t (in-list closure-types)] (for ([t (in-list closure-types)]
[i (in-naturals num-all-params)]) [i (in-naturals num-all-params)])
(when (eq? t 'flonum) (set-bit! i 2))) (case t
[(val/ref) (void)]
[else (set-bit! i (+ 1 (type->index t)))]))
(vector->list v)))) (vector->list v))))
closure-map)) closure-map))
l)] l)]