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

update for with-immediate-continuation-mark and scope IDs

Browse Source
This commit is contained in:
Matthew Flatt 2015-08-06 15:11:39 -06:00
parent cb1c9aabe6
commit 92e9ac99f5
4 changed files with 48 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
compiler-lib/compiler/decompile.rkt
View File

@ -184,8 +184,9 @@
(length toplevels)
(length stxs)
num-lifts)
(cons
(list*
`(quote inspector ,src-insp-desc)
;; `(quote tls ,toplevels)
(map (lambda (stx id)
`(define ,id ,(if stx
`(#%decode-syntax
@ -487,6 +488,12 @@
[(struct apply-values (proc args-expr))
`(#%apply-values ,(decompile-expr proc globs stack closed)
,(decompile-expr args-expr globs stack closed))]
[(struct with-immed-mark (key-expr val-expr body-expr))
(let ([id (gensym 'cmval)])
`(#%call-with-immediate-continuation-mark
,(decompile-expr key-expr globs stack closed)
(lambda (,id) ,(decompile-expr body-expr globs (cons id stack) closed))
,(decompile-expr val-expr globs stack closed)))]
[(struct seq (exprs))
`(begin ,@(for/list ([expr (in-list exprs)])
(decompile-expr expr globs stack closed)))]
@ -540,7 +547,7 @@
,@(if (not tl-map)
'()
(list
(for/list ([pos (in-set tl-map)])
(for/list ([pos (in-list (sort (set->list tl-map) <))])
(define tl-pos
(cond
[(or (pos . < . (glob-desc-num-tls globs))

25
zo-lib/compiler/zo-marshal.rkt
View File

@ -20,7 +20,7 @@
(struct not-ready ())
(struct encoded-scope ([content #:mutable]) #:prefab)
(struct encoded-scope (relative-id [content #:mutable]) #:prefab)
(define (zo-marshal top)
(define bs (open-output-bytes))
@ -291,11 +291,12 @@
(define require-form-type-num 22)
(define varref-form-type-num 23)
(define apply-values-type-num 24)
(define case-lambda-sequence-type-num 25)
(define module-type-num 26)
(define inline-variants-type-num 27)
(define variable-type-num 35)
(define prefix-type-num 120)
(define with-immed-mark-type-num 25)
(define case-lambda-sequence-type-num 26)
(define module-type-num 27)
(define inline-variants-type-num 28)
(define variable-type-num 36)
(define prefix-type-num 121)
(define-syntax define-enum
(syntax-rules ()
@ -753,6 +754,13 @@
(cons (protect-quote proc)
(protect-quote args-expr))
out)]
[(struct with-immed-mark (key val body))
(out-marshaled with-immed-mark-type-num
(vector
(protect-quote key)
(protect-quote val)
(protect-quote body))
out)]
[(struct with-cont-mark (key val body))
(out-marshaled wcm-type-num
(list*
@ -881,12 +889,13 @@
[(stx content)
(out-byte CPT_STX out)
(out-anything content out)]
[(encoded-scope content)
[(encoded-scope relative-id content)
(out-byte CPT_SCOPE out)
;; The `out-shared` wrapper already called `((out-shared-index out) v)`
;; once, so `pos` will defintely be a number:
(let ([pos ((out-shared-index out) v)])
(out-number pos out))
(out-number relative-id out)
(out-anything (share-everywhere content out) out)]
[(? stx-obj?)
(out-anything (share-everywhere (lookup-encoded-stx-obj v out) out) out)]
@ -1229,7 +1238,7 @@
s
(hash-ref ht s
(lambda ()
(define es (encoded-scope #f))
(define es (encoded-scope (scope-name s) #f))
(hash-set! ht s es)
(define kind
(case (scope-kind s)

29
zo-lib/compiler/zo-parse.rkt
View File

@ -192,6 +192,8 @@
(make-varref (car v) (cdr v)))
(define (read-apply-values v)
(make-apply-values (car v) (cdr v)))
(define (read-with-immed-mark v)
(make-with-immed-mark (vector-ref v 0) (vector-ref v 1) (vector-ref v 2)))
(define (read-splice v)
(make-splice v))
@ -372,12 +374,13 @@
[(22) 'require-form-type]
[(23) 'varref-form-type]
[(24) 'apply-values-type]
[(25) 'case-lambda-sequence-type]
[(26) 'module-type]
[(27) 'inline-variant-type]
[(35) 'variable-type]
[(36) 'module-variable-type]
[(120) 'resolve-prefix-type]
[(25) 'with-immed-mark-type]
[(26) 'case-lambda-sequence-type]
[(27) 'module-type]
[(28) 'inline-variant-type]
[(36) 'variable-type]
[(37) 'module-variable-type]
[(121) 'resolve-prefix-type]
[else (error 'int->type "unknown type: ~e" i)]))
(define type-readers
@ -407,6 +410,7 @@
(cons 'require-form-type read-require)
(cons 'varref-form-type read-#%variable-ref)
(cons 'apply-values-type read-apply-values)
(cons 'with-immed-mark-type read-with-immed-mark)
(cons 'splice-sequence-type read-splice))))
(define (get-reader type)
@ -592,7 +596,7 @@
(with-memo* mt arg (λ () body ...)))
;; placeholder for a `scope` decoded in a second pass:
(struct encoded-scope (content) #:prefab)
(struct encoded-scope (relative-id content) #:prefab)
(define (decode-wrapped cp v)
(let loop ([v v])
@ -942,10 +946,13 @@
[(small-svector)
(read-compact-svector cp (- ch cpt-start))]
[(scope)
(let ([pos (read-compact-number cp)])
(let ([pos (read-compact-number cp)]
[relative-id (read-compact-number cp)])
(if (zero? pos)
(encoded-scope (read-compact cp))
(read-cyclic cp pos 'scope encoded-scope)))]
(encoded-scope relative-id (read-compact cp))
(read-cyclic cp pos 'scope (lambda (v)
(encoded-scope relative-id
v)))))]
[(root-scope)
root-scope]
[(shared)
@ -1254,7 +1261,7 @@
[(cons (? number?) _)
(car v)]
[else (error 'decode-wrap "bad scope")]))
(define sc (scope (hash-count ht)
(define sc (scope (encoded-scope-relative-id s)
(case kind
[(0 1) 'module]
[(2) 'macro]

5
zo-lib/compiler/zo-structs.rkt
View File

@ -170,6 +170,9 @@
(define-form-struct (varref expr) ([toplevel (or/c toplevel? #t)] [dummy (or/c toplevel? #f)])) ; `#%variable-reference'
(define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set!
(define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc)
(define-form-struct (with-immed-mark expr) ([key (or/c expr? seq? any/c)]
[def-val (or/c expr? seq? any/c)]
[body (or/c expr? seq? any/c)]))
(define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive
;; Top-level `require'
@ -186,7 +189,7 @@
(define-form-struct wrap ([shifts (listof module-shift?)]
[simple-scopes (listof scope?)]
[multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer?)))]))
[multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer? (box/c exact-integer?))))]))
(define-form-struct module-shift ([from (or/c #f module-path-index?)]
[to (or/c #f module-path-index?)]