Matthew Flatt
commit
a290d88c64
279
collects/compiler/decompile.ss
Normal file
279
collects/compiler/decompile.ss
Normal file
|
|
@ -0,0 +1,279 @@
|
|||
#lang scheme
|
||||
(require compiler/zo-parse
|
||||
syntax/modcollapse)
|
||||
|
||||
(provide decompile)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define primitive-table
|
||||
;; Figure out number-to-id mapping for kernel functions in `primitive'
|
||||
(let ([bindings
|
||||
(let ([ns (make-base-empty-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-require ''#%kernel)
|
||||
(for/list ([l (namespace-mapped-symbols)])
|
||||
(cons l (with-handlers ([exn:fail? (lambda (x) #f)])
|
||||
(compile l))))))]
|
||||
[table (make-hash)])
|
||||
(for ([b (in-list bindings)])
|
||||
(let ([v (and (cdr b)
|
||||
(zo-parse (let-values ([(in out) (make-pipe)])
|
||||
(write (cdr b) out)
|
||||
(close-output-port out)
|
||||
in)))])
|
||||
(let ([n (match v
|
||||
[(struct compilation-top (_ prefix (struct primitive (n)))) n]
|
||||
[else #f])])
|
||||
(hash-set! table n (car b)))))
|
||||
table))
|
||||
|
||||
(define (list-ref/protect l pos)
|
||||
(list-ref l pos)
|
||||
#;
|
||||
(if (pos . < . (length l))
|
||||
(list-ref l pos)
|
||||
'OUT-OF-BOUNDS))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Main entry:
|
||||
(define (decompile top)
|
||||
(match top
|
||||
[(struct compilation-top (_ prefix (and (? mod?) mod)))
|
||||
(decompile-module mod)]
|
||||
[(struct compilation-top (_ prefix form))
|
||||
(let-values ([(globs defns) (decompile-prefix prefix)])
|
||||
`(begin
|
||||
,@defns
|
||||
,(decompile-form form globs '(#%prefix))))]
|
||||
[else (error 'decompile "unrecognized: ~e" top)]))
|
||||
|
||||
(define (decompile-prefix a-prefix)
|
||||
(match a-prefix
|
||||
[(struct prefix (num-lifts toplevels stxs))
|
||||
(let ([lift-ids (for/list ([i (in-range num-lifts)])
|
||||
(gensym 'lift))]
|
||||
[stx-ids (map (lambda (i) (gensym 'stx))
|
||||
stxs)])
|
||||
(values (append
|
||||
(map (lambda (tl)
|
||||
(match tl
|
||||
[(struct global-bucket (name)) name]
|
||||
[(struct module-variable (modidx sym pos phase))
|
||||
(if (and (module-path-index? modidx)
|
||||
(let-values ([(n b) (module-path-index-split modidx)])
|
||||
(and (not n) (not b))))
|
||||
sym
|
||||
(string->symbol (format "~s@~s~a" sym (mpi->string modidx)
|
||||
(if (zero? phase)
|
||||
""
|
||||
(format "/~a" phase)))))]
|
||||
[else (error 'decompile-prefix "bad toplevel: ~e" tl)]))
|
||||
toplevels)
|
||||
stx-ids
|
||||
(if (null? stx-ids) null '(#%stx-array))
|
||||
lift-ids)
|
||||
(map (lambda (stx id)
|
||||
`(define ,id (decode-stx ,(stx-encoded stx))))
|
||||
stxs stx-ids)))]
|
||||
[else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
|
||||
|
||||
(define (mpi->string modidx)
|
||||
(cond
|
||||
[(symbol? modidx) modidx]
|
||||
[else (collapse-module-path-index modidx (current-directory))]))
|
||||
|
||||
(define (decompile-module mod-form)
|
||||
(match mod-form
|
||||
[(struct mod (name self-modidx prefix provides requires body syntax-body))
|
||||
(let-values ([(globs defns) (decompile-prefix prefix)])
|
||||
`(module ,name ....
|
||||
,@defns
|
||||
,@(map (lambda (form)
|
||||
(decompile-form form globs '(#%prefix)))
|
||||
syntax-body)
|
||||
,@(map (lambda (form)
|
||||
(decompile-form form globs '(#%prefix)))
|
||||
body)))]
|
||||
[else (error 'decompile-module "huh?: ~e" mod-form)]))
|
||||
|
||||
(define (decompile-form form globs stack)
|
||||
(match form
|
||||
[(struct def-values (ids rhs))
|
||||
`(define-values ,(map (lambda (tl)
|
||||
(match tl
|
||||
[(struct toplevel (depth pos flags))
|
||||
(list-ref/protect globs pos)]))
|
||||
ids)
|
||||
,(decompile-expr rhs globs stack))]
|
||||
[(struct def-syntaxes (ids rhs prefix max-let-depth))
|
||||
`(define-syntaxes ,ids
|
||||
,(let-values ([(globs defns) (decompile-prefix prefix)])
|
||||
`(let ()
|
||||
,@defns
|
||||
,(decompile-expr rhs globs '(#%prefix)))))]
|
||||
[(struct def-for-syntax (ids rhs prefix max-let-depth))
|
||||
`(define-values-for-syntax ,ids
|
||||
,(let-values ([(globs defns) (decompile-prefix prefix)])
|
||||
`(let ()
|
||||
,@defns
|
||||
,(decompile-expr rhs globs '(#%prefix)))))]
|
||||
[(struct sequence (forms))
|
||||
`(begin ,@(map (lambda (form)
|
||||
(decompile-form form globs stack))
|
||||
forms))]
|
||||
[(struct splice (forms))
|
||||
`(begin ,@(map (lambda (form)
|
||||
(decompile-form form globs stack))
|
||||
forms))]
|
||||
[else
|
||||
(decompile-expr form globs stack)]))
|
||||
|
||||
(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 rest? closure-map max-let-depth body))
|
||||
(extract-name name)]
|
||||
[(struct case-lam (name lams))
|
||||
(extract-name name)]
|
||||
[(struct closure (lam gen-id))
|
||||
(extract-id lam)]
|
||||
[(struct indirect (v))
|
||||
(extract-id v)]
|
||||
[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-expr expr globs stack)
|
||||
(match expr
|
||||
[(struct toplevel (depth pos flags))
|
||||
(list-ref/protect globs pos)]
|
||||
[(struct topsyntax (depth pos midpt))
|
||||
(list-ref/protect globs (+ midpt pos))]
|
||||
[(struct primitive (id))
|
||||
(hash-ref primitive-table id)]
|
||||
[(struct assign (id rhs undef-ok?))
|
||||
`(set! ,(decompile-expr id globs stack)
|
||||
,(decompile-expr rhs globs stack))]
|
||||
[(struct localref (unbox? offset flags))
|
||||
(let ([id (list-ref/protect stack offset)])
|
||||
(if unbox?
|
||||
`(#%unbox ,id)
|
||||
id))]
|
||||
[(struct lam (name flags num-params rest? closure-map max-let-depth body))
|
||||
(let ([vars (for/list ([i (in-range num-params)]) (gensym 'arg))]
|
||||
[rest-vars (if rest? (list (gensym 'rest)) null)])
|
||||
`(lambda (,@vars . ,(if rest?
|
||||
(car rest-vars)
|
||||
null))
|
||||
,@(if name
|
||||
`(',name)
|
||||
null)
|
||||
,(decompile-expr body globs (append
|
||||
(map (lambda (v)
|
||||
(list-ref/protect stack v))
|
||||
(vector->list closure-map))
|
||||
(append vars rest-vars)))))]
|
||||
[(struct let-one (rhs body))
|
||||
(let ([id (or (extract-id rhs)
|
||||
(gensym 'local))])
|
||||
`(let ([,id ,(decompile-expr rhs globs (cons id stack))])
|
||||
,(decompile-expr body globs (cons id stack))))]
|
||||
[(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 'localv)))])
|
||||
`(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)])
|
||||
vars)
|
||||
,(decompile-expr body globs (append vars stack)))))]
|
||||
[(struct let-rec (procs body))
|
||||
`(begin
|
||||
(set!-rec-values ,(for/list ([p (in-list procs)]
|
||||
[i (in-naturals)])
|
||||
(list-ref/protect stack i))
|
||||
,@(map (lambda (proc)
|
||||
(decompile-expr proc globs stack))
|
||||
procs))
|
||||
,(decompile-expr body globs stack))]
|
||||
[(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)))
|
||||
,(decompile-expr rhs globs stack))
|
||||
,(decompile-expr body globs stack))]
|
||||
[(struct boxenv (pos body))
|
||||
(let ([id (list-ref/protect stack pos)])
|
||||
`(begin
|
||||
(set! ,id (#%box ,id))
|
||||
,(decompile-expr body globs stack)))]
|
||||
[(struct branch (test then else))
|
||||
`(if ,(decompile-expr test globs stack)
|
||||
,(decompile-expr then globs stack)
|
||||
,(decompile-expr else globs stack))]
|
||||
[(struct application (rator rands))
|
||||
(let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
|
||||
stack)])
|
||||
`(,(decompile-expr rator globs stack)
|
||||
,@(map (lambda (rand)
|
||||
(decompile-expr rand globs stack))
|
||||
rands)))]
|
||||
[(struct apply-values (proc args-expr))
|
||||
`(apply-values ,(decompile-expr proc globs stack)
|
||||
,(decompile-expr args-expr globs stack))]
|
||||
[(struct sequence (exprs))
|
||||
`(begin ,@(for/list ([expr (in-list exprs)])
|
||||
(decompile-expr expr globs stack)))]
|
||||
[(struct beg0 (exprs))
|
||||
`(begin0 ,@(for/list ([expr (in-list exprs)])
|
||||
(decompile-expr expr globs stack)))]
|
||||
[(struct closure (lam gen-id))
|
||||
`(CLOSED ,gen-id ,(decompile-expr lam globs stack))]
|
||||
[(struct indirect (val))
|
||||
(if (closure? val)
|
||||
(closure-gen-id val)
|
||||
'???)]
|
||||
[else `(quote ,expr)]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
#;
|
||||
(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)))))
|
||||
683
collects/compiler/zo-parse.ss
Normal file
683
collects/compiler/zo-parse.ss
Normal file
|
|
@ -0,0 +1,683 @@
|
|||
#lang scheme
|
||||
(require mzlib/etc
|
||||
scheme/list)
|
||||
|
||||
(provide zo-parse)
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Structures to represent bytecode
|
||||
|
||||
(define-syntax-rule (define-form-struct id (field-id ...))
|
||||
(begin
|
||||
(define-struct id (field-id ...) #:transparent)
|
||||
(provide (struct-out id))))
|
||||
|
||||
(define-form-struct compilation-top (max-let-depth prefix code)) ; compiled code always wrapped with this
|
||||
|
||||
(define-form-struct prefix (num-lifts toplevels stxs)) ; sets up top-level and syntax-object array
|
||||
|
||||
;; In toplevels of resove prefix:
|
||||
(define-form-struct global-bucket (name)) ; top-level binding
|
||||
(define-form-struct module-variable (modidx sym pos phase)) ; direct access to exported id
|
||||
|
||||
;; In stxs of prefix:
|
||||
(define-form-struct stx (encoded)) ; todo: decode syntax objects
|
||||
|
||||
(define-form-struct mod (name self-modidx prefix provides requires body syntax-body))
|
||||
|
||||
(define-form-struct lam (name flags num-params rest? closure-map max-let-depth body)) ; `lambda'
|
||||
(define-form-struct closure (code gen-id)) ; a static closure (nothing to close over)
|
||||
(define-form-struct case-lam (name clauses)) ; each clause is an lam
|
||||
|
||||
(define-form-struct let-one (rhs body)) ; pushes one value onto stack
|
||||
(define-form-struct let-void (count boxes? body)) ; create new stack slots
|
||||
(define-form-struct install-value (count pos boxes? rhs body)) ; set existing stack slot(s)
|
||||
(define-form-struct let-rec (procs body)) ; put `letrec'-bound closures into existing stack slots
|
||||
(define-form-struct boxenv (pos body)) ; box existing stack element
|
||||
|
||||
(define-form-struct localref (unbox? offset flags)) ; access local via stack
|
||||
|
||||
(define-form-struct toplevel (depth pos flags)) ; access binding via prefix array (which is on stack)
|
||||
(define-form-struct topsyntax (depth pos midpt)) ; access syntax object via prefix array (which is on stack)
|
||||
|
||||
(define-form-struct application (rator rands)) ; function call
|
||||
(define-form-struct branch (test then else)) ; `if'
|
||||
(define-form-struct with-cont-mark (key val body)) ; `with-continuation-mark'
|
||||
(define-form-struct beg0 (seq)) ; `begin0'
|
||||
(define-form-struct sequence (forms)) ; `begin'
|
||||
(define-form-struct splice (forms)) ; top-level `begin'
|
||||
(define-form-struct varref (toplevel)) ; `#%variable-reference'
|
||||
(define-form-struct assign (id rhs undef-ok?)) ; top-level or module-level set!
|
||||
(define-form-struct apply-values (proc args-expr)) ; `(call-with-values (lambda () ,args-expr) ,proc)
|
||||
(define-form-struct primitive (id)) ; direct preference to a kernel primitive
|
||||
|
||||
;; Definitions (top level or within module):
|
||||
(define-form-struct def-values (ids rhs))
|
||||
(define-form-struct def-syntaxes (ids rhs prefix max-let-depth))
|
||||
(define-form-struct def-for-syntax (ids rhs prefix max-let-depth))
|
||||
|
||||
;; Top-level `require'
|
||||
(define-form-struct req (reqs dummy))
|
||||
|
||||
;; A static closure can refer directly to itself, creating a cycle
|
||||
(define-struct indirect ([v #:mutable]) #:prefab)
|
||||
(provide (struct-out indirect))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Bytecode unmarshalers for various forms
|
||||
|
||||
(define (read-toplevel v)
|
||||
(define toplevel-flags-mask 3)
|
||||
(match v
|
||||
[(cons depth (cons pos flags))
|
||||
(make-toplevel depth pos (bitwise-and flags toplevel-flags-mask))]
|
||||
[(cons depth pos)
|
||||
(make-toplevel depth pos 0)]))
|
||||
|
||||
(define (read-topsyntax v)
|
||||
(match v
|
||||
[`(,depth ,pos . ,midpt)
|
||||
(make-topsyntax depth pos midpt)]))
|
||||
|
||||
(define (read-variable v)
|
||||
(if (symbol? v)
|
||||
(make-global-bucket v)
|
||||
(let-values ([(phase modname varname)
|
||||
(match v
|
||||
[(list* phase modname varname)
|
||||
(values phase modname varname)]
|
||||
[(list* modname varname)
|
||||
(values 0 modname varname)])])
|
||||
(if (and (zero? phase) (eq? modname '#%kernel))
|
||||
(error 'bucket "var ~a" varname)
|
||||
(make-module-variable modname varname -1 phase)))))
|
||||
|
||||
(define (read-compilation-top v)
|
||||
(match v
|
||||
[`(,ld ,prefix . ,code)
|
||||
(unless (prefix? prefix)
|
||||
(error 'bad "not prefix ~a" prefix))
|
||||
(make-compilation-top ld prefix code)]))
|
||||
|
||||
(define (read-resolve-prefix v)
|
||||
(match v
|
||||
[`(,i ,tv . ,sv)
|
||||
(make-prefix i (vector->list tv) (vector->list sv))]))
|
||||
|
||||
(define (read-unclosed-procedure v)
|
||||
(define CLOS_HAS_REST 1)
|
||||
(define CLOS_HAS_REF_ARGS 2)
|
||||
(match v
|
||||
[`(,flags ,num-params ,max-let-depth ,name ,v . ,rest)
|
||||
(let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))])
|
||||
(let-values ([(closure-size closed-over body)
|
||||
(if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
|
||||
(values #f v rest)
|
||||
(values v (car rest) (cdr rest)))])
|
||||
(make-lam name
|
||||
flags
|
||||
((if rest? sub1 values) num-params)
|
||||
rest?
|
||||
closed-over
|
||||
max-let-depth
|
||||
body)))]))
|
||||
|
||||
(define (read-let-value v)
|
||||
(match v
|
||||
[`(,count ,pos ,boxes? ,rhs . ,body)
|
||||
(make-install-value count pos boxes? rhs body)]))
|
||||
|
||||
(define (read-let-void v)
|
||||
(match v
|
||||
[`(,count ,boxes? . ,body)
|
||||
(make-let-void count boxes? body)]))
|
||||
|
||||
(define (read-letrec v)
|
||||
(match v
|
||||
[`(,count ,body . ,procs)
|
||||
(make-let-rec procs body)]))
|
||||
|
||||
(define (read-with-cont-mark v)
|
||||
(match v
|
||||
[`(,key ,val . ,body)
|
||||
(make-with-cont-mark key val body)]))
|
||||
|
||||
(define (read-sequence v)
|
||||
(make-sequence v))
|
||||
|
||||
(define (read-define-values v)
|
||||
(make-def-values
|
||||
(cdr (vector->list v))
|
||||
(vector-ref v 0)))
|
||||
|
||||
(define (read-define-syntaxes mk v)
|
||||
(mk (list-tail (vector->list v) 4)
|
||||
(vector-ref v 0)
|
||||
(vector-ref v 1)
|
||||
(vector-ref v 2)
|
||||
#;(vector-ref v 3)))
|
||||
|
||||
(define (read-define-syntax v)
|
||||
(read-define-syntaxes make-def-syntaxes v))
|
||||
|
||||
(define (read-define-for-syntax v)
|
||||
(read-define-syntaxes make-def-for-syntax v))
|
||||
|
||||
(define (read-set! v)
|
||||
(make-assign (cadr v) (cddr v) (car v)))
|
||||
|
||||
(define (read-case-lambda v)
|
||||
(make-case-lam (car v) (cdr v)))
|
||||
|
||||
(define (read-begin0 v)
|
||||
(match v
|
||||
[(struct sequence (exprs))
|
||||
(make-beg0 exprs)]))
|
||||
|
||||
(define (read-boxenv v)
|
||||
(make-boxenv (car v) (cdr v)))
|
||||
(define (read-require v)
|
||||
(make-req (cdr v) (car v)))
|
||||
(define (read-#%variable-ref v)
|
||||
(make-varref v))
|
||||
(define (read-apply-values v)
|
||||
(make-apply-values (car v) (cdr v)))
|
||||
(define (read-splice v)
|
||||
(make-splice v))
|
||||
|
||||
(define (read-module v)
|
||||
(match v
|
||||
[`(,name ,self-modidx ,functional? ,et-functional?
|
||||
,rename ,max-let-depth ,dummy
|
||||
,prefix ,kernel-exclusion ,reprovide-kernel?
|
||||
,indirect-provides ,num-indirect-provides ,protects
|
||||
,provide-phase-count . ,rest)
|
||||
(let ([phase-data (take rest (* 8 provide-phase-count))])
|
||||
(match (list-tail rest (* 8 provide-phase-count))
|
||||
[`(,syntax-body ,body
|
||||
,requires ,syntax-requires ,template-requires ,label-requires
|
||||
,more-requires-count . ,more-requires)
|
||||
(make-mod name self-modidx
|
||||
prefix phase-data
|
||||
(list*
|
||||
(cons 0 requires)
|
||||
(cons 1 syntax-requires)
|
||||
(cons -1 template-requires)
|
||||
(cons #f label-requires)
|
||||
more-requires)
|
||||
(vector->list body)
|
||||
(map (lambda (sb)
|
||||
(match sb
|
||||
[`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
|
||||
((if for-stx?
|
||||
make-def-for-syntax
|
||||
make-def-syntaxes)
|
||||
ids expr prefix max-let-depth)]))
|
||||
(vector->list syntax-body)))]))]))
|
||||
(define (read-module-wrap v)
|
||||
v)
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Unmarshal dispatch for various types
|
||||
|
||||
(define (read-more-syntax v)
|
||||
(let ([id (car v)]
|
||||
[v (cdr v)])
|
||||
;; This is the ..._EXPD mapping from "schpriv.h":
|
||||
(case id
|
||||
[(0) (read-define-values v)]
|
||||
[(1) (read-define-syntax v)]
|
||||
[(2) (read-set! v)]
|
||||
[(3) (read-case-lambda v)]
|
||||
[(4) (read-begin0 v)]
|
||||
[(5) (read-boxenv v)]
|
||||
[(6) (read-module-wrap v)]
|
||||
[(7) (read-require v)]
|
||||
[(8) (read-define-for-syntax v)]
|
||||
[(9) (read-#%variable-ref v)]
|
||||
[(10) (read-apply-values v)]
|
||||
[(11) (read-splice v)]
|
||||
[else (error 'read-mode-unsyntax "unknown id: ~e" id)])))
|
||||
|
||||
;; Type mappings from "stypes.h":
|
||||
(define (int->type i)
|
||||
(case i
|
||||
[(0) 'toplevel-type]
|
||||
[(3) 'syntax-type]
|
||||
[(7) 'sequence-type]
|
||||
[(9) 'unclosed-procedure-type]
|
||||
[(10) 'let-value-type]
|
||||
[(11) 'let-void-type]
|
||||
[(12) 'letrec-type]
|
||||
[(14) 'with-cont-mark-type]
|
||||
[(15) 'quote-syntax-type]
|
||||
[(24) 'variable-type]
|
||||
[(96) 'case-lambda-sequence-type]
|
||||
[(97) 'begin0-sequence-type]
|
||||
[(100) 'module-type]
|
||||
[(103) 'resolve-prefix-type]
|
||||
[else (error 'int->type "unknown type: ~e" i)]))
|
||||
|
||||
(define type-readers
|
||||
(make-immutable-hash
|
||||
(list
|
||||
(cons 'toplevel-type read-toplevel)
|
||||
(cons 'syntax-type read-more-syntax)
|
||||
(cons 'sequence-type read-sequence)
|
||||
(cons 'unclosed-procedure-type read-unclosed-procedure)
|
||||
(cons 'let-value-type read-let-value)
|
||||
(cons 'let-void-type read-let-void)
|
||||
(cons 'letrec-type read-letrec)
|
||||
(cons 'with-cont-mark-type read-with-cont-mark)
|
||||
(cons 'quote-syntax-type read-topsyntax)
|
||||
(cons 'variable-type read-variable)
|
||||
(cons 'compilation-top-type read-compilation-top)
|
||||
(cons 'case-lambda-sequence-type read-case-lambda)
|
||||
(cons 'begin0-sequence-type read-sequence)
|
||||
(cons 'module-type read-module)
|
||||
(cons 'resolve-prefix-type read-resolve-prefix))))
|
||||
|
||||
(define (get-reader type)
|
||||
(or (hash-ref type-readers type #f)
|
||||
(lambda (v)
|
||||
(error 'read-marshalled "reader for ~a not implemented" type))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Lowest layer of bytecode parsing
|
||||
|
||||
(define (split-so all-short so)
|
||||
(define n (if (zero? all-short) 4 2))
|
||||
(let loop ([so so])
|
||||
(if (zero? (bytes-length so))
|
||||
null
|
||||
(cons (integer-bytes->integer (subbytes so 0 n) #f)
|
||||
(loop (subbytes so n))))))
|
||||
|
||||
(define (read-simple-number p)
|
||||
;; not sure if it's really unsigned
|
||||
(integer-bytes->integer (read-bytes 4 p) #f #f))
|
||||
|
||||
(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets))
|
||||
|
||||
(define (cp-getc cp)
|
||||
(begin-with-definitions
|
||||
(when ((cport-pos cp) . >= . (cport-size cp))
|
||||
(error "off the end"))
|
||||
(define r
|
||||
(bytes-ref (cport-bytes cp) (cport-pos cp)))
|
||||
(set-cport-pos! cp (add1 (cport-pos cp)))
|
||||
r))
|
||||
|
||||
(define small-list-max 65)
|
||||
(define cpt-table
|
||||
;; The "schcpt.h" mapping
|
||||
`([0 escape]
|
||||
[1 symbol]
|
||||
[2 symref]
|
||||
[3 weird-symbol]
|
||||
[4 keyword]
|
||||
[5 byte-string]
|
||||
[6 string]
|
||||
[7 char]
|
||||
[8 int]
|
||||
[9 null]
|
||||
[10 true]
|
||||
[11 false]
|
||||
[12 void]
|
||||
[13 box]
|
||||
[14 pair]
|
||||
[15 list]
|
||||
[16 vector]
|
||||
[17 hash-table]
|
||||
[18 stx]
|
||||
[19 gstx] ; unused
|
||||
[20 marshalled]
|
||||
[21 quote]
|
||||
[22 reference]
|
||||
[23 local]
|
||||
[24 local-unbox]
|
||||
[25 svector]
|
||||
[26 application]
|
||||
[27 let-one]
|
||||
[28 branch]
|
||||
[29 module-index]
|
||||
[30 module-var]
|
||||
[31 path]
|
||||
[32 closure]
|
||||
[33 delayed]
|
||||
[34 prefab]
|
||||
[35 60 small-number]
|
||||
[60 80 small-symbol]
|
||||
[80 92 small-marshalled]
|
||||
[92 ,(+ 92 small-list-max) small-proper-list]
|
||||
[,(+ 92 small-list-max) 192 small-list]
|
||||
[192 207 small-local]
|
||||
[207 222 small-local-unbox]
|
||||
[222 247 small-svector]
|
||||
[248 small-application2]
|
||||
[249 small-application3]
|
||||
[247 255 small-application]))
|
||||
|
||||
(define (cpt-table-lookup i)
|
||||
(for/or ([ent cpt-table])
|
||||
(match ent
|
||||
[(list k sym) (and (= k i) (cons k sym))]
|
||||
[(list k k* sym)
|
||||
(and (<= k i)
|
||||
(< i k*)
|
||||
(cons k sym))])))
|
||||
|
||||
(define (read-compact-bytes port c)
|
||||
(begin0
|
||||
(subbytes (cport-bytes port) (cport-pos port) (+ (cport-pos port) c))
|
||||
(set-cport-pos! port (+ c (cport-pos port)))))
|
||||
|
||||
(define (read-compact-chars port c)
|
||||
(bytes->string/utf-8 (read-compact-bytes port c)))
|
||||
|
||||
(define (read-compact-list c proper port)
|
||||
(cond [(= 0 c)
|
||||
(if proper null (read-compact port))]
|
||||
[else (cons (read-compact port) (read-compact-list (sub1 c) proper port))]))
|
||||
|
||||
(define (read-compact-number port)
|
||||
(define flag (cp-getc port))
|
||||
(cond [(< flag 128)
|
||||
flag]
|
||||
[(zero? (bitwise-and flag #x40))
|
||||
(let ([a (cp-getc port)])
|
||||
(+ (a . << . 6) (bitwise-and flag 63)))]
|
||||
[(zero? (bitwise-and flag #x20))
|
||||
(- (bitwise-and flag #x1F))]
|
||||
[else
|
||||
(let ([a (cp-getc port)]
|
||||
[b (cp-getc port)]
|
||||
[c (cp-getc port)]
|
||||
[d (cp-getc port)])
|
||||
(let ([n (integer-bytes->integer (bytes a b c d) #f #f)])
|
||||
(if (zero? (bitwise-and flag #x10))
|
||||
(- n)
|
||||
n)))]))
|
||||
|
||||
(define (read-compact-svector port n)
|
||||
(list->vector (reverse (for/list ([i (in-range n)]) (read-compact-number port)))))
|
||||
|
||||
(define (read-marshalled type port)
|
||||
(let* ([type (if (number? type) (int->type type) type)]
|
||||
[l (read-compact port)]
|
||||
[reader (get-reader type)])
|
||||
(reader l)))
|
||||
|
||||
(define (a . << . b)
|
||||
(arithmetic-shift a b))
|
||||
|
||||
(define-struct not-ready ())
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Main parsing loop
|
||||
|
||||
(define (read-compact cp)
|
||||
(let loop ([need-car 0] [proper #f] [last #f] [first #f])
|
||||
(begin-with-definitions
|
||||
(define ch (cp-getc cp))
|
||||
(define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)])
|
||||
(unless x
|
||||
(error 'read-compact "unknown code : ~a" ch))
|
||||
(values (car x) (cdr x))))
|
||||
(define v
|
||||
(case cpt-tag
|
||||
[(delayed)
|
||||
(let ([pos (read-compact-number cp)])
|
||||
(let ([v (vector-ref (cport-symtab cp) pos)])
|
||||
(if (not-ready? v)
|
||||
(let ([save-pos (cport-pos cp)])
|
||||
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos)))
|
||||
(let ([v (read-compact cp)])
|
||||
(vector-set! (cport-symtab cp) pos v)
|
||||
(set-cport-pos! cp save-pos)
|
||||
v))
|
||||
v)))]
|
||||
[(escape)
|
||||
(let* ([len (read-compact-number cp)]
|
||||
[s (subbytes (cport-bytes cp) (cport-pos cp) (+ (cport-pos cp) len))])
|
||||
(set-cport-pos! cp (+ (cport-pos cp) len))
|
||||
(parameterize ([read-accept-compiled #t]
|
||||
[read-accept-bar-quote #t]
|
||||
[read-accept-box #t]
|
||||
[read-accept-graph #t]
|
||||
[read-case-sensitive #t]
|
||||
[read-square-bracket-as-paren #t]
|
||||
[read-curly-brace-as-paren #t]
|
||||
[read-decimal-as-inexact #t]
|
||||
[read-accept-dot #t]
|
||||
[read-accept-infix-dot #t]
|
||||
[read-accept-quasiquote #t])
|
||||
(read (open-input-bytes s))))]
|
||||
[(reference)
|
||||
(make-primitive (read-compact-number cp))]
|
||||
[(small-list small-proper-list)
|
||||
(let* ([l (- ch cpt-start)]
|
||||
[ppr (eq? cpt-tag 'small-proper-list)])
|
||||
(if (positive? need-car)
|
||||
(if (= l 1)
|
||||
(cons (read-compact cp)
|
||||
(if ppr null (read-compact cp)))
|
||||
(read-compact-list l ppr cp))
|
||||
(loop l ppr last first)))]
|
||||
[(let-one)
|
||||
(make-let-one (read-compact cp) (read-compact cp))]
|
||||
[(branch)
|
||||
(make-branch (read-compact cp) (read-compact cp) (read-compact cp))]
|
||||
[(module-index) (module-path-index-join (read-compact cp) (read-compact cp))]
|
||||
[(module-var)
|
||||
(let ([mod (read-compact cp)]
|
||||
[var (read-compact cp)]
|
||||
[pos (read-compact-number cp)])
|
||||
(make-module-variable mod var pos 0))]
|
||||
[(local-unbox)
|
||||
(let* ([p* (read-compact-number cp)]
|
||||
[p (if (< p* 0)
|
||||
(- (add1 p*))
|
||||
p*)]
|
||||
[flags (if (< p* 0)
|
||||
(read-compact-number cp)
|
||||
0)])
|
||||
(make-localref #t p flags))]
|
||||
[(path)
|
||||
(let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))])
|
||||
(if (relative-path? p)
|
||||
(path->complete-path p (or (current-load-relative-directory)
|
||||
(current-directory)))
|
||||
p))]
|
||||
[(small-number)
|
||||
(let ([l (- ch cpt-start)])
|
||||
l)]
|
||||
[(int)
|
||||
(read-compact-number cp)]
|
||||
[(false) #f]
|
||||
[(true) #t]
|
||||
[(null) null]
|
||||
[(void) (void)]
|
||||
[(vector) (let* ([n (read-compact-number cp)]
|
||||
[lst (for/list ([i (in-range n)])
|
||||
(read-compact cp))])
|
||||
(vector->immutable-vector (list->vector lst)))]
|
||||
[(list) (let* ([n (read-compact-number cp)])
|
||||
(for/list ([i (in-range n)])
|
||||
(read-compact cp)))]
|
||||
[(prefab)
|
||||
(let ([v (read-compact cp)])
|
||||
(apply make-prefab-struct
|
||||
(vector-ref v 0)
|
||||
(cdr (vector->list v))))]
|
||||
[(hash-table)
|
||||
(let ([eq (read-compact-number cp)]
|
||||
[len (read-compact-number cp)])
|
||||
((if (zero? eq)
|
||||
make-hash-placeholder
|
||||
make-hasheq-placeholder)
|
||||
(for/list ([i (in-range len)])
|
||||
(cons (read-compact cp)
|
||||
(read-compact cp)))))]
|
||||
[(marshalled) (read-marshalled (read-compact-number cp) cp)]
|
||||
[(stx)
|
||||
(let ([v (make-reader-graph (read-compact cp))])
|
||||
(make-stx v))]
|
||||
[(local local-unbox)
|
||||
(let ([c (read-compact-number cp)]
|
||||
[unbox? (eq? cpt-tag 'local-unbox)])
|
||||
(if (negative? c)
|
||||
(make-localref unbox? (- (add1 c)) (read-compact-number cp))
|
||||
(make-localref unbox? c 0)))]
|
||||
[(small-local)
|
||||
(make-localref #f (- ch cpt-start) 0)]
|
||||
[(small-local-unbox)
|
||||
(make-localref #t (- ch cpt-start) 0)]
|
||||
[(small-symbol)
|
||||
(let ([l (- ch cpt-start)])
|
||||
(string->symbol (read-compact-chars cp l)))]
|
||||
[(symbol)
|
||||
(let ([l (read-compact-number cp)])
|
||||
(string->symbol (read-compact-chars cp l)))]
|
||||
[(keyword)
|
||||
(let ([l (read-compact-number cp)])
|
||||
(string->keyword (read-compact-chars cp l)))]
|
||||
[(byte-string)
|
||||
(let ([l (read-compact-number cp)])
|
||||
(read-compact-bytes cp l))]
|
||||
[(string)
|
||||
(let ([l (read-compact-number cp)]
|
||||
[cl (read-compact-number cp)])
|
||||
(read-compact-chars cp l))]
|
||||
[(char)
|
||||
(integer->char (read-compact-number cp))]
|
||||
[(box)
|
||||
(box (read-compact cp))]
|
||||
[(quote)
|
||||
(make-reader-graph (read-compact cp))]
|
||||
[(symref)
|
||||
(let* ([l (read-compact-number cp)]
|
||||
[v (vector-ref (cport-symtab cp) l)])
|
||||
(if (not-ready? v)
|
||||
(let ([pos (cport-pos cp)])
|
||||
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 l)))
|
||||
(let ([v (read-compact cp)])
|
||||
(set-cport-pos! cp pos)
|
||||
(vector-set! (cport-symtab cp) l v)
|
||||
v))
|
||||
v))]
|
||||
[(weird-symbol)
|
||||
(let ([u (read-compact-number cp)]
|
||||
[str (read-compact-chars cp (read-compact-number cp))])
|
||||
;; FIXME: no way to construct quasi-interned symbols:
|
||||
(string->uninterned-symbol str))]
|
||||
[(small-marshalled)
|
||||
(read-marshalled (- ch cpt-start) cp)]
|
||||
[(small-application2)
|
||||
(make-application (read-compact cp)
|
||||
(list (read-compact cp)))]
|
||||
[(small-application3)
|
||||
(make-application (read-compact cp)
|
||||
(list (read-compact cp)
|
||||
(read-compact cp)))]
|
||||
[(small-application)
|
||||
(let ([c (add1 (- ch cpt-start))])
|
||||
(make-application (read-compact cp)
|
||||
(for/list ([i (in-range (sub1 c))])
|
||||
(read-compact cp))))]
|
||||
[(application)
|
||||
(let ([c (read-compact-number cp)])
|
||||
(make-application (read-compact cp)
|
||||
(for/list ([i (in-range c)])
|
||||
(read-compact cp))))]
|
||||
[(closure)
|
||||
(let* ([l (read-compact-number cp)]
|
||||
[ind (make-indirect #f)])
|
||||
(vector-set! (cport-symtab cp) l ind)
|
||||
(let* ([v (read-compact cp)]
|
||||
[cl (make-closure v (gensym
|
||||
(let ([s (lam-name v)])
|
||||
(cond
|
||||
[(symbol? s) s]
|
||||
[(vector? s) (vector-ref s 0)]
|
||||
[else 'closure]))))])
|
||||
(vector-set! (cport-symtab cp) l cl)
|
||||
(set-indirect-v! ind cl)
|
||||
cl))]
|
||||
[(svector)
|
||||
(read-compact-svector cp (read-compact-number cp))]
|
||||
[(small-svector)
|
||||
(read-compact-svector cp (- ch cpt-start))]
|
||||
[else (error 'read-compact "unknown tag ~a" cpt-tag)]))
|
||||
(cond
|
||||
[(zero? need-car) v]
|
||||
[(and proper (= need-car 1))
|
||||
(cons v null)]
|
||||
[else
|
||||
(cons v (loop (sub1 need-car) proper last first))]))))
|
||||
|
||||
;; path -> bytes
|
||||
;; implementes read.c:read_compiled
|
||||
(define (zo-parse port)
|
||||
(begin-with-definitions
|
||||
;; skip the "#~"
|
||||
(read-bytes 2 port)
|
||||
|
||||
(define version (read-bytes (min 63 (read-byte port)) port))
|
||||
|
||||
(define symtabsize (read-simple-number port))
|
||||
|
||||
(define all-short (read-byte port))
|
||||
|
||||
(define cnt (* (if (not (zero? all-short)) 2 4)
|
||||
(sub1 symtabsize)))
|
||||
|
||||
(define so (read-bytes cnt port))
|
||||
|
||||
(define so* (list->vector (split-so all-short so)))
|
||||
|
||||
(define shared-size (read-simple-number port))
|
||||
(define size* (read-simple-number port))
|
||||
|
||||
(when (shared-size . >= . size*)
|
||||
(error 'bad-read))
|
||||
|
||||
(define rst (read-bytes size* port))
|
||||
|
||||
(unless (eof-object? (read port))
|
||||
(error 'not-end))
|
||||
|
||||
(unless (= size* (bytes-length rst))
|
||||
(error "wrong number of bytes"))
|
||||
|
||||
(define symtab (make-vector symtabsize (make-not-ready)))
|
||||
|
||||
(define cp (make-cport 0 port size* rst symtab so*))
|
||||
(for/list ([i (in-range 1 symtabsize)])
|
||||
(when (not-ready? (vector-ref symtab i))
|
||||
(set-cport-pos! cp (vector-ref so* (sub1 i)))
|
||||
(let ([v (read-compact cp)])
|
||||
(vector-set! symtab i v))))
|
||||
(set-cport-pos! cp shared-size)
|
||||
(read-marshalled 'compilation-top-type cp)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
#;
|
||||
(begin
|
||||
(define (compile/write sexp)
|
||||
(define s (open-output-bytes))
|
||||
(write (parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval '(require (for-syntax scheme/base)))
|
||||
(compile sexp))
|
||||
s)
|
||||
(get-output-bytes s))
|
||||
|
||||
(define (compile/parse sexp)
|
||||
(let* ([bs (compile/write sexp)]
|
||||
[p (open-input-bytes bs)])
|
||||
(zo-parse p)))
|
||||
|
||||
#;(compile/parse #s(foo 10 13))
|
||||
(zo-parse (open-input-file "/home/mflatt/proj/plt/collects/scheme/private/compiled/more-scheme_ss.zo"))
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user