59ef254318
This commit merges changes that were developed in the "racket7" repo. See that repo (which is no longer modified) for a more fine-grained change history. The commit includes experimental support for running Racket on Chez Scheme, but that "CS" variant is not built by default.
718 lines
28 KiB
Racket
718 lines
28 KiB
Racket
#lang racket/base
|
|
(require racket/linklet
|
|
compiler/zo-parse
|
|
compiler/zo-marshal
|
|
syntax/modcollapse
|
|
racket/port
|
|
racket/match
|
|
racket/list
|
|
racket/set
|
|
racket/path
|
|
(only-in '#%linklet compiled-position->primitive)
|
|
"private/deserialize.rkt")
|
|
|
|
(provide decompile)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define primitive-table
|
|
(let ([value-names (let ([ns (make-base-empty-namespace)])
|
|
(parameterize ([current-namespace ns])
|
|
(namespace-require ''#%kernel)
|
|
(namespace-require ''#%unsafe)
|
|
(namespace-require ''#%flfxnum)
|
|
(namespace-require ''#%extfl)
|
|
(namespace-require ''#%futures)
|
|
(namespace-require ''#%foreign)
|
|
(namespace-require ''#%paramz)
|
|
(for/hasheq ([name (in-list (namespace-mapped-symbols))])
|
|
(values (namespace-variable-value name #t (lambda () #f))
|
|
name))))])
|
|
(for/hash ([i (in-naturals)]
|
|
#:break (not (compiled-position->primitive i)))
|
|
(define v (compiled-position->primitive i))
|
|
(values i (or (hash-ref value-names v #f) `',v)))))
|
|
|
|
(define (list-ref/protect l pos who)
|
|
(list-ref l pos)
|
|
#;
|
|
(if (pos . < . (length l))
|
|
(list-ref l pos)
|
|
`(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-struct glob-desc (vars))
|
|
|
|
;; Main entry:
|
|
(define (decompile top #:to-linklets? [to-linklets? #f])
|
|
(cond
|
|
[(linkl-directory? top)
|
|
(cond
|
|
[to-linklets?
|
|
(cons
|
|
'linklet-directory
|
|
(apply
|
|
append
|
|
(for/list ([(k v) (in-hash (linkl-directory-table top))])
|
|
(list '#:name k '#:bundle (decompile v #:to-linklets? to-linklets?)))))]
|
|
[else
|
|
(define main (hash-ref (linkl-directory-table top) '() #f))
|
|
(unless main (error 'decompile "cannot find main module"))
|
|
(decompile-module-with-submodules top '() main)])]
|
|
[(linkl-bundle? top)
|
|
(cond
|
|
[to-linklets?
|
|
(cons
|
|
'linklet-bundle
|
|
(apply
|
|
append
|
|
(for/list ([(k v) (in-hash (linkl-bundle-table top))])
|
|
(case (and (not to-linklets?) k)
|
|
[(stx-data)
|
|
(list '#:stx-data (decompile-data-linklet v))]
|
|
[else
|
|
(list '#:key k '#:value (decompile v #:to-linklets? to-linklets?))]))))]
|
|
[else
|
|
(decompile-module top)])]
|
|
[(linkl? top)
|
|
(decompile-linklet top)]
|
|
[else `(quote ,top)]))
|
|
|
|
(define (decompile-module-with-submodules l-dir name-list main-l)
|
|
(decompile-module main-l
|
|
(lambda ()
|
|
(for/list ([(k l) (in-hash (linkl-directory-table l-dir))]
|
|
#:when (and (list? k)
|
|
(= (length k) (add1 (length name-list)))
|
|
(for/and ([s1 (in-list name-list)]
|
|
[s2 (in-list k)])
|
|
(eq? s1 s2))))
|
|
(decompile-module-with-submodules l-dir k l)))))
|
|
|
|
(define (decompile-module l [get-nested (lambda () '())])
|
|
(define ht (linkl-bundle-table l))
|
|
(define phases (sort (for/list ([k (in-hash-keys ht)]
|
|
#:when (exact-integer? k))
|
|
k)
|
|
<))
|
|
(define-values (mpi-vector requires provides)
|
|
(let ([data-l (hash-ref ht 'data #f)]
|
|
[decl-l (hash-ref ht 'decl #f)])
|
|
(define (zo->linklet l)
|
|
(let ([o (open-output-bytes)])
|
|
(zo-marshal-to (linkl-bundle (hasheq 'data l)) o)
|
|
(parameterize ([read-accept-compiled #t])
|
|
(define b (read (open-input-bytes (get-output-bytes o))))
|
|
(hash-ref (linklet-bundle->hash b) 'data))))
|
|
(cond
|
|
[(and data-l
|
|
decl-l)
|
|
(define data-i (instantiate-linklet (zo->linklet data-l)
|
|
(list deserialize-instance)))
|
|
(define decl-i (instantiate-linklet (zo->linklet decl-l)
|
|
(list deserialize-instance
|
|
data-i)))
|
|
(values (instance-variable-value data-i '.mpi-vector)
|
|
(instance-variable-value decl-i 'requires)
|
|
(instance-variable-value decl-i 'provides))]
|
|
[else (values '#() '() '())])))
|
|
(define (phase-wrap phase l)
|
|
(case phase
|
|
[(0) l]
|
|
[(1) `((for-syntax ,@l))]
|
|
[(-1) `((for-template ,@l))]
|
|
[(#f) `((for-label ,@l))]
|
|
[else `((for-meta ,phase ,@l))]))
|
|
`(module ,(hash-ref ht 'name 'unknown) ....
|
|
(require ,@(apply
|
|
append
|
|
(for/list ([phase+mpis (in-list requires)])
|
|
(phase-wrap (car phase+mpis)
|
|
(map collapse-module-path-index (cdr phase+mpis))))))
|
|
(provide ,@(apply
|
|
append
|
|
(for/list ([(phase ht) (in-hash provides)])
|
|
(phase-wrap phase (hash-keys ht)))))
|
|
,@(let loop ([phases phases] [depth 0])
|
|
(cond
|
|
[(null? phases) '()]
|
|
[(= depth (car phases))
|
|
(append
|
|
(decompile-linklet (hash-ref ht (car phases)) #:just-body? #t)
|
|
(loop (cdr phases) depth))]
|
|
[else
|
|
(define l (loop phases (add1 depth)))
|
|
(define (convert-syntax-definition s wrap)
|
|
(match s
|
|
[`(let ,bindings ,body)
|
|
(convert-syntax-definition body
|
|
(lambda (rhs)
|
|
`(let ,bindings
|
|
,rhs)))]
|
|
[`(begin (.set-transformer! ',id ,rhs) ',(? void?))
|
|
`(define-syntaxes ,id ,(wrap rhs))]
|
|
[`(begin (.set-transformer! ',ids ,rhss) ... ',(? void?))
|
|
`(define-syntaxes ,ids ,(wrap `(values . ,rhss)))]
|
|
[_ #f]))
|
|
(let loop ([l l] [accum '()])
|
|
(cond
|
|
[(null? l) (if (null? accum)
|
|
'()
|
|
`((begin-for-syntax ,@(reverse accum))))]
|
|
[(convert-syntax-definition (car l) values)
|
|
=> (lambda (s)
|
|
(append (loop null accum)
|
|
(cons s (loop (cdr l) null))))]
|
|
[else
|
|
(loop (cdr l) (cons (car l) accum))]))]))
|
|
,@(get-nested)
|
|
,@(let ([l (hash-ref ht 'stx-data #f)])
|
|
(if l
|
|
`((begin-for-all
|
|
(define (.get-syntax-literal! pos)
|
|
....
|
|
,(decompile-data-linklet l)
|
|
....)))
|
|
null))))
|
|
|
|
|
|
(define (decompile-linklet l #:just-body? [just-body? #f])
|
|
(match l
|
|
[(struct linkl (name importss import-shapess exports internals lifts source-names body max-let-depth needs-instance?))
|
|
(define closed (make-hasheq))
|
|
(define globs (glob-desc
|
|
(append
|
|
(list 'root)
|
|
(apply append importss)
|
|
exports
|
|
internals
|
|
lifts)))
|
|
(define body-l
|
|
(for/list ([form (in-list body)])
|
|
(decompile-form form globs '(#%globals) closed)))
|
|
(if just-body?
|
|
body-l
|
|
`(linklet
|
|
,importss
|
|
,exports
|
|
'(import-shapes: ,@(for/list ([imports (in-list importss)]
|
|
[import-shapes (in-list import-shapess)]
|
|
#:when #t
|
|
[import (in-list imports)]
|
|
[import-shape (in-list import-shapes)]
|
|
#:when import-shape)
|
|
`[,import ,import-shape]))
|
|
,@body-l))]))
|
|
|
|
(define (decompile-data-linklet l)
|
|
(match l
|
|
[(struct linkl (_ _ _ _ _ _ _ (list vec-def (struct def-values (_ deser-lam))) _ _))
|
|
(match deser-lam
|
|
[(struct lam (_ _ _ _ _ _ _ _ _ (struct seq ((list vec-copy! _)))))
|
|
(match vec-copy!
|
|
[(struct application (_ (list _ _ (struct application (_ (list mpi-vector inspector bulk-binding-registry
|
|
num-mutables mutable-vec
|
|
num-shares share-vec
|
|
mutable-fill-vec
|
|
result-vec))))))
|
|
(decompile-deserialize '.mpi-vector '.inspector '.bulk-binding-registry
|
|
num-mutables mutable-vec
|
|
num-shares share-vec
|
|
mutable-fill-vec
|
|
result-vec)]
|
|
[else
|
|
(decompile-linklet l)])]
|
|
[else
|
|
(decompile-linklet l)])]
|
|
[else
|
|
(decompile-linklet l)]))
|
|
|
|
(define (decompile-form form globs stack closed)
|
|
(match form
|
|
[(struct def-values (ids rhs))
|
|
`(define-values ,(map (lambda (tl)
|
|
(match tl
|
|
[(struct toplevel (depth pos const? set-const?))
|
|
(list-ref/protect (glob-desc-vars globs) pos 'def-vals)]))
|
|
ids)
|
|
,(if (inline-variant? rhs)
|
|
`(begin
|
|
,(list 'quote '%%inline-variant%%)
|
|
,(decompile-expr (inline-variant-inline rhs) globs stack closed)
|
|
,(decompile-expr (inline-variant-direct rhs) globs stack closed))
|
|
(decompile-expr rhs globs stack closed)))]
|
|
[(struct seq (forms))
|
|
`(begin ,@(map (lambda (form)
|
|
(decompile-form form globs stack closed))
|
|
forms))]
|
|
[else
|
|
(decompile-expr form globs stack closed)]))
|
|
|
|
(define (extract-name name)
|
|
(if (symbol? name)
|
|
(gensym name)
|
|
(if (vector? name)
|
|
(gensym (vector-ref name 0))
|
|
#f)))
|
|
|
|
(define (extract-id expr)
|
|
(match expr
|
|
[(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body))
|
|
(extract-name name)]
|
|
[(struct case-lam (name lams))
|
|
(extract-name name)]
|
|
[(struct closure (lam gen-id))
|
|
(extract-id lam)]
|
|
[else #f]))
|
|
|
|
(define (extract-ids! body ids)
|
|
(match body
|
|
[(struct let-rec (procs body))
|
|
(for ([proc (in-list procs)]
|
|
[delta (in-naturals)])
|
|
(when (< -1 delta (vector-length ids))
|
|
(vector-set! ids delta (extract-id proc))))
|
|
(extract-ids! body ids)]
|
|
[(struct install-value (val-count pos boxes? rhs body))
|
|
(extract-ids! body ids)]
|
|
[(struct boxenv (pos body))
|
|
(extract-ids! body ids)]
|
|
[else #f]))
|
|
|
|
(define (decompile-tl expr globs stack closed no-check?)
|
|
(match expr
|
|
[(struct toplevel (depth pos const? ready?))
|
|
(let ([id (list-ref/protect (glob-desc-vars globs) pos 'toplevel)])
|
|
(cond
|
|
[no-check? id]
|
|
[(and (not const?) (not ready?))
|
|
`(#%checked ,id)]
|
|
#;[(and const? ready?) `(#%const ,id)]
|
|
#;[const? `(#%iconst ,id)]
|
|
[else id]))]))
|
|
|
|
(define (decompile-expr expr globs stack closed)
|
|
(match expr
|
|
[(struct toplevel (depth pos const? ready?))
|
|
(decompile-tl expr globs stack closed #f)]
|
|
[(struct varref (tl dummy constant? from-unsafe?))
|
|
`(#%variable-reference . ,(cond
|
|
[(not tl) '()]
|
|
[(eq? tl #t) '(<constant-local>)]
|
|
[(symbol? tl) (list tl)] ; primitive
|
|
[else (list (decompile-tl tl globs stack closed #t))]))]
|
|
[(struct primval (id))
|
|
(hash-ref primitive-table id (lambda () (error "unknown primitive: " id)))]
|
|
[(struct assign (id rhs undef-ok?))
|
|
`(set! ,(decompile-expr id globs stack closed)
|
|
,(decompile-expr rhs globs stack closed))]
|
|
[(struct localref (unbox? offset clear? other-clears? type))
|
|
(let ([id (list-ref/protect stack offset 'localref)])
|
|
(let ([e (if unbox?
|
|
`(#%unbox ,id)
|
|
id)])
|
|
(if clear?
|
|
`(#%sfs-clear ,e)
|
|
e)))]
|
|
[(? lam?)
|
|
`(lambda . ,(decompile-lam expr globs stack closed))]
|
|
[(struct case-lam (name lams))
|
|
`(case-lambda
|
|
,@(map (lambda (lam)
|
|
(decompile-lam lam globs stack closed))
|
|
lams))]
|
|
[(struct let-one (rhs body type unused?))
|
|
(let ([id (or (extract-id rhs)
|
|
(gensym (or type (if unused? 'unused 'local))))])
|
|
`(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)])
|
|
,(decompile-expr body globs (cons id stack) closed)))]
|
|
[(struct let-void (count boxes? body))
|
|
(let ([ids (make-vector count #f)])
|
|
(extract-ids! body ids)
|
|
(let ([vars (for/list ([i (in-range count)]
|
|
[id (in-vector ids)])
|
|
(or id (gensym (if boxes? 'localvb 'localv))))])
|
|
`(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)])
|
|
vars)
|
|
,(decompile-expr body globs (append vars stack) closed))))]
|
|
[(struct let-rec (procs body))
|
|
`(begin
|
|
(#%set!-rec-values ,(for/list ([p (in-list procs)]
|
|
[i (in-naturals)])
|
|
(list-ref/protect stack i 'let-rec))
|
|
,@(map (lambda (proc)
|
|
(decompile-expr proc globs stack closed))
|
|
procs))
|
|
,(decompile-expr body globs stack closed))]
|
|
[(struct install-value (count pos boxes? rhs body))
|
|
`(begin
|
|
(,(if boxes? '#%set-boxes! 'set!-values)
|
|
,(for/list ([i (in-range count)])
|
|
(list-ref/protect stack (+ i pos) 'install-value))
|
|
,(decompile-expr rhs globs stack closed))
|
|
,(decompile-expr body globs stack closed))]
|
|
[(struct boxenv (pos body))
|
|
(let ([id (list-ref/protect stack pos 'boxenv)])
|
|
`(begin
|
|
(set! ,id (#%box ,id))
|
|
,(decompile-expr body globs stack closed)))]
|
|
[(struct branch (test then else))
|
|
`(if ,(decompile-expr test globs stack closed)
|
|
,(decompile-expr then globs stack closed)
|
|
,(decompile-expr else globs stack closed))]
|
|
[(struct application (rator rands))
|
|
(let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
|
|
stack)])
|
|
(annotate-unboxed
|
|
rands
|
|
(annotate-inline
|
|
`(,(decompile-expr rator globs stack closed)
|
|
,@(map (lambda (rand)
|
|
(decompile-expr rand globs stack closed))
|
|
rands)))))]
|
|
[(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)))]
|
|
[(struct beg0 (exprs))
|
|
`(begin0
|
|
,@(for/list ([expr (in-list exprs)])
|
|
(decompile-expr expr globs stack closed))
|
|
;; Make sure a single expression doesn't look like tail position:
|
|
,@(if (null? (cdr exprs)) (list #f) null))]
|
|
[(struct with-cont-mark (key val body))
|
|
`(with-continuation-mark
|
|
,(decompile-expr key globs stack closed)
|
|
,(decompile-expr val globs stack closed)
|
|
,(decompile-expr body globs stack closed))]
|
|
[(struct closure (lam gen-id))
|
|
(if (hash-ref closed gen-id #f)
|
|
gen-id
|
|
(begin
|
|
(hash-set! closed gen-id #t)
|
|
`(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))]
|
|
[else `(quote ,expr)]))
|
|
|
|
(define (decompile-lam expr globs stack closed)
|
|
(match expr
|
|
[(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)]
|
|
[(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body))
|
|
(let ([vars (for/list ([i (in-range num-params)]
|
|
[type (in-list arg-types)])
|
|
(gensym (format "~a~a-"
|
|
(case type
|
|
[(ref) "argbox"]
|
|
[(val) "arg"]
|
|
[else (format "arg~a" type)])
|
|
i)))]
|
|
[rest-vars (if rest? (list (gensym 'rest)) null)]
|
|
[captures (map (lambda (v)
|
|
(list-ref/protect stack v 'lam))
|
|
(vector->list closure-map))])
|
|
`((,@vars . ,(if rest?
|
|
(car rest-vars)
|
|
null))
|
|
,@(if (and name (not (null? name)))
|
|
`(',name)
|
|
null)
|
|
,@(if (null? flags) null `('(flags: ,@flags)))
|
|
,@(if (null? captures)
|
|
null
|
|
`('(captures: ,@(map (lambda (c t)
|
|
(if t
|
|
`(,t ,c)
|
|
c))
|
|
captures
|
|
closure-types)
|
|
,@(if (not tl-map)
|
|
'()
|
|
(list
|
|
(for/list ([pos (in-list (sort (set->list tl-map) <))])
|
|
(list-ref/protect (glob-desc-vars globs)
|
|
pos
|
|
'lam)))))))
|
|
,(decompile-expr body globs
|
|
(append captures
|
|
(append vars rest-vars))
|
|
closed)))]))
|
|
|
|
(define (annotate-inline a)
|
|
a)
|
|
|
|
(define (annotate-unboxed args a)
|
|
a)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (decompile-deserialize mpis inspector bulk-binding-registry
|
|
num-mutables mutable-vec
|
|
num-shares share-vec
|
|
mutable-fill-vec
|
|
result-vec)
|
|
;; Names for shared values:
|
|
(define shared (for/vector ([i (in-range (+ num-mutables num-shares))])
|
|
(string->symbol (format "~a:~a"
|
|
(if (i . < . num-mutables)
|
|
'mutable
|
|
'shared)
|
|
i))))
|
|
(define (infer-name! d i)
|
|
(when (pair? d)
|
|
(define new-name
|
|
(case (car d)
|
|
[(deserialize-scope) 'scope]
|
|
[(srcloc) 'srcloc]
|
|
[else #f]))
|
|
(when new-name
|
|
(vector-set! shared i (string->symbol (format "~a:~a" new-name i))))))
|
|
|
|
(define mutables (make-vector num-mutables #f))
|
|
;; Make mutable shells
|
|
(for/fold ([pos 0]) ([i (in-range num-mutables)])
|
|
(define-values (d next-pos)
|
|
(decode-shell mutable-vec pos mpis inspector bulk-binding-registry shared))
|
|
(vector-set! mutables i d)
|
|
(infer-name! d i)
|
|
next-pos)
|
|
|
|
;; Construct shared values
|
|
(define shareds (make-vector num-shares #f))
|
|
(for/fold ([pos 0]) ([i (in-range num-shares)])
|
|
(define-values (d next-pos)
|
|
(decode share-vec pos mpis inspector bulk-binding-registry shared))
|
|
(vector-set! shareds i d)
|
|
(infer-name! d (+ i num-mutables))
|
|
next-pos)
|
|
|
|
;; Fill in mutable shells
|
|
(define-values (fill-pos rev-fills)
|
|
(for/fold ([pos 0] [rev-fills null]) ([i (in-range num-mutables)]
|
|
[v (in-vector shared)])
|
|
(define-values (fill next-pos)
|
|
(decode-fill! v mutable-fill-vec pos mpis inspector bulk-binding-registry shared))
|
|
(values next-pos (if fill
|
|
(cons fill rev-fills)
|
|
rev-fills))))
|
|
|
|
;; Construct the final result
|
|
(define-values (result done-pos)
|
|
(decode result-vec 0 mpis inspector bulk-binding-registry shared))
|
|
|
|
`(let (,(for/list ([i (in-range num-mutables)])
|
|
`(,(vector-ref shared i) ,(vector-ref mutables i))))
|
|
(let* (,(for/list ([i (in-range num-shares)])
|
|
`(,(vector-ref shared (+ i num-mutables)) ,(vector-ref shareds i))))
|
|
,@(reverse rev-fills)
|
|
,result)))
|
|
|
|
;; Decode the construction of a mutable variable
|
|
(define (decode-shell vec pos mpis inspector bulk-binding-registry shared)
|
|
(case (vector-ref vec pos)
|
|
[(#:box) (values (list 'box #f) (add1 pos))]
|
|
[(#:vector) (values `(make-vector ,(vector-ref vec (add1 pos))) (+ pos 2))]
|
|
[(#:hash) (values (list 'make-hasheq) (add1 pos))]
|
|
[(#:hasheq) (values (list 'make-hasheq) (add1 pos))]
|
|
[(#:hasheqv) (values (list 'make-hasheqv) (add1 pos))]
|
|
[else (decode vec pos mpis inspector bulk-binding-registry shared)]))
|
|
|
|
;; The decoder that is used for most purposes
|
|
(define (decode vec pos mpis inspector bulk-binding-registry shared)
|
|
(define-syntax decodes
|
|
(syntax-rules ()
|
|
[(_ (id ...) rhs) (decodes #:pos (add1 pos) (id ...) rhs)]
|
|
[(_ #:pos pos () rhs) (values rhs pos)]
|
|
[(_ #:pos pos ([#:ref id0] id ...) rhs)
|
|
(let-values ([(id0 next-pos) (let ([i (vector-ref vec pos)])
|
|
(if (exact-integer? i)
|
|
(values (vector-ref shared i) (add1 pos))
|
|
(decode vec pos mpis inspector bulk-binding-registry shared)))])
|
|
(decodes #:pos next-pos (id ...) rhs))]
|
|
[(_ #:pos pos (id0 id ...) rhs)
|
|
(let-values ([(id0 next-pos) (decode vec pos mpis inspector bulk-binding-registry shared)])
|
|
(decodes #:pos next-pos (id ...) rhs))]))
|
|
(define-syntax-rule (decode* (deser id ...))
|
|
(decodes (id ...) `(deser ,id ...)))
|
|
(case (vector-ref vec pos)
|
|
[(#:ref)
|
|
(values (vector-ref shared (vector-ref vec (add1 pos)))
|
|
(+ pos 2))]
|
|
[(#:inspector) (values inspector (add1 pos))]
|
|
[(#:bulk-binding-registry) (values bulk-binding-registry (add1 pos))]
|
|
[(#:syntax #:datum->syntax)
|
|
(decodes
|
|
(content [#:ref context] [#:ref srcloc])
|
|
`(deserialize-syntax
|
|
,content
|
|
,context
|
|
,srcloc
|
|
#f
|
|
#f
|
|
,inspector))]
|
|
[(#:syntax+props)
|
|
(decodes
|
|
(content [#:ref context] [#:ref srcloc] props tamper)
|
|
`(deserialize-syntax
|
|
,content
|
|
,context
|
|
,srcloc
|
|
,props
|
|
,tamper
|
|
,inspector))]
|
|
[(#:srcloc)
|
|
(decode* (srcloc source line column position span))]
|
|
[(#:quote)
|
|
(values (vector-ref vec (add1 pos)) (+ pos 2))]
|
|
[(#:mpi)
|
|
(values `(vector-ref ,mpis ,(vector-ref vec (add1 pos)))
|
|
(+ pos 2))]
|
|
[(#:box)
|
|
(decode* (box-immutable v))]
|
|
[(#:cons)
|
|
(decode* (cons a d))]
|
|
[(#:list #:vector #:set #:seteq #:seteqv)
|
|
(define len (vector-ref vec (add1 pos)))
|
|
(define r (make-vector len))
|
|
(define next-pos
|
|
(for/fold ([pos (+ pos 2)]) ([i (in-range len)])
|
|
(define-values (v next-pos) (decodes #:pos pos (v) v))
|
|
(vector-set! r i v)
|
|
next-pos))
|
|
(values `(,(case (vector-ref vec pos)
|
|
[(#:list) 'list]
|
|
[(#:vector) 'vector]
|
|
[(#:set) 'set]
|
|
[(#:seteq) 'seteq]
|
|
[(#:seteqv) 'seteqv])
|
|
,@(vector->list r))
|
|
next-pos)]
|
|
[(#:hash #:hasheq #:hasheqv)
|
|
(define len (vector-ref vec (add1 pos)))
|
|
(define-values (l next-pos)
|
|
(for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)])
|
|
(decodes #:pos pos (k v) (list* v k l))))
|
|
(values `(,(case (vector-ref vec pos)
|
|
[(#:hash) 'hash]
|
|
[(#:hasheq) 'hasheq]
|
|
[(#:hasheqv) 'hasheqv])
|
|
,@(reverse l))
|
|
next-pos)]
|
|
[(#:prefab)
|
|
(define-values (key next-pos) (decodes #:pos (add1 pos) (k) k))
|
|
(define len (vector-ref vec next-pos))
|
|
(define-values (r done-pos)
|
|
(for/fold ([r null] [pos (add1 next-pos)]) ([i (in-range len)])
|
|
(decodes #:pos pos (v) (cons v r))))
|
|
(values `(make-prefab-struct ',key ,@(reverse r))
|
|
done-pos)]
|
|
[(#:scope)
|
|
(decode* (deserialize-scope))]
|
|
[(#:scope+kind)
|
|
(decode* (deserialize-scope kind))]
|
|
[(#:multi-scope)
|
|
(decode* (deserialize-multi-scope name scopes))]
|
|
[(#:shifted-multi-scope)
|
|
(decode* (deserialize-shifted-multi-scope phase multi-scope))]
|
|
[(#:table-with-bulk-bindings)
|
|
(decode* (deserialize-table-with-bulk-bindings syms bulk-bindings))]
|
|
[(#:bulk-binding-at)
|
|
(decode* (deserialize-bulk-binding-at scopes bulk))]
|
|
[(#:representative-scope)
|
|
(decode* (deserialize-representative-scope kind phase))]
|
|
[(#:module-binding)
|
|
(decode* (deserialize-full-module-binding
|
|
module sym phase
|
|
nominal-module
|
|
nominal-phase
|
|
nominal-sym
|
|
nominal-require-phase
|
|
free=id
|
|
extra-inspector
|
|
extra-nominal-bindings))]
|
|
[(#:simple-module-binding)
|
|
(decode* (deserialize-simple-module-binding module sym phase nominal-module))]
|
|
[(#:local-binding)
|
|
(decode* (deserialize-full-local-binding key free=id))]
|
|
[(#:bulk-binding)
|
|
(decode* (deserialize-bulk-binding prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry))]
|
|
[(#:provided)
|
|
(decode* (deserialize-provided binding protected? syntax?))]
|
|
[else
|
|
(values `(quote ,(vector-ref vec pos)) (add1 pos))]))
|
|
|
|
;; Decode the filling of mutable values, which has its own encoding
|
|
;; variant
|
|
(define (decode-fill! v vec pos mpis inspector bulk-binding-registry shared)
|
|
(case (vector-ref vec pos)
|
|
[(#f) (values #f (add1 pos))]
|
|
[(#:set-box!)
|
|
(define-values (c next-pos)
|
|
(decode vec (add1 pos) mpis inspector bulk-binding-registry shared))
|
|
(values `(set-box! ,v ,c)
|
|
next-pos)]
|
|
[(#:set-vector!)
|
|
(define len (vector-ref vec (add1 pos)))
|
|
(define-values (l next-pos)
|
|
(for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)])
|
|
(define-values (c next-pos)
|
|
(decode vec pos mpis inspector bulk-binding-registry shared))
|
|
(values (cons `(vector-set! ,v ,i ,c) l)
|
|
next-pos)))
|
|
(values `(begin ,@(reverse l)) next-pos)]
|
|
[(#:set-hash!)
|
|
(define len (vector-ref vec (add1 pos)))
|
|
(define-values (l next-pos)
|
|
(for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)])
|
|
(define-values (key next-pos)
|
|
(decode vec pos mpis inspector bulk-binding-registry shared))
|
|
(define-values (val done-pos)
|
|
(decode vec next-pos mpis inspector bulk-binding-registry shared))
|
|
(values (cons `(hash-set! ,v ,key ,val) l)
|
|
done-pos)))
|
|
(values `(begin ,@(reverse l)) next-pos)]
|
|
[(#:scope-fill!)
|
|
(define-values (c next-pos)
|
|
(decode vec (add1 pos) mpis inspector bulk-binding-registry shared))
|
|
(values `(deserialize-scope-fill! ,v ,c)
|
|
next-pos)]
|
|
[(#:representative-scope-fill!)
|
|
(define-values (a next-pos)
|
|
(decode vec (add1 pos) mpis inspector bulk-binding-registry shared))
|
|
(define-values (d done-pos)
|
|
(decode vec next-pos mpis inspector bulk-binding-registry shared))
|
|
(values `(deserialize-representative-scope-fill! ,v ,a ,d)
|
|
done-pos)]
|
|
[else
|
|
(error 'deserialize "bad fill encoding: ~v" (vector-ref vec pos))]))
|
|
|
|
|
|
;; ----------------------------------------
|
|
|
|
#;
|
|
(begin
|
|
(require scheme/pretty)
|
|
(define (try e)
|
|
(pretty-print
|
|
(decompile
|
|
(zo-parse (let-values ([(in out) (make-pipe)])
|
|
(write (parameterize ([current-namespace (make-base-namespace)])
|
|
(compile e))
|
|
out)
|
|
(close-output-port out)
|
|
in)))))
|
|
(pretty-print
|
|
(decompile
|
|
(zo-parse (open-input-file "/home/mflatt/proj/plt/collects/tests/mzscheme/benchmarks/common/sboyer_ss.zo"))))
|
|
#;
|
|
(try '(lambda (q . more)
|
|
(letrec ([f (lambda (x) f)])
|
|
(lambda (g) f)))))
|