diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 70a64f71c1..4fc5259255 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -28,12 +28,12 @@ (hash-set! table n (car b))))) table)) -(define (list-ref/protect l pos) +(define (list-ref/protect l pos who) (list-ref l pos) #; (if (pos . < . (length l)) (list-ref l pos) - `(OUT-OF-BOUNDS ,pos ,l))) + `(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l))) ;; ---------------------------------------- @@ -44,7 +44,7 @@ (let-values ([(globs defns) (decompile-prefix prefix)]) `(begin ,@defns - ,(decompile-form form globs '(#%globals))))] + ,(decompile-form form globs '(#%globals) (make-hasheq))))] [else (error 'decompile "unrecognized: ~e" top)])) (define (decompile-prefix a-prefix) @@ -76,7 +76,7 @@ lift-ids) (map (lambda (stx id) `(define ,id ,(if stx - `(#%decode-syntax ,(stx-encoded stx)) + `(#%decode-syntax ,stx #;(stx-encoded stx)) #f))) stxs stx-ids)))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) @@ -90,18 +90,19 @@ (match mod-form [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) (let-values ([(globs defns) (decompile-prefix prefix)] - [(stack) (append '(#%modvars) stack)]) + [(stack) (append '(#%modvars) stack)] + [(closed) (make-hasheq)]) `(module ,name .... ,@defns ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) syntax-body) ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) body)))] [else (error 'decompile-module "huh?: ~e" mod-form)])) -(define (decompile-form form globs stack) +(define (decompile-form form globs stack closed) (match form [(? mod?) (decompile-module form stack)] @@ -109,31 +110,31 @@ `(define-values ,(map (lambda (tl) (match tl [(struct toplevel (depth pos const? mutated?)) - (list-ref/protect globs pos)])) + (list-ref/protect globs pos 'def-vals)])) ids) - ,(decompile-expr rhs globs stack))] + ,(decompile-expr rhs globs stack closed))] [(struct def-syntaxes (ids rhs prefix max-let-depth)) `(define-syntaxes ,ids ,(let-values ([(globs defns) (decompile-prefix prefix)]) `(let () ,@defns - ,(decompile-form rhs globs '(#%globals)))))] + ,(decompile-form rhs globs '(#%globals) closed))))] [(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 '(#%globals)))))] + ,(decompile-expr rhs globs '(#%globals) closed))))] [(struct sequence (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) forms))] [(struct splice (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) forms))] [else - (decompile-expr form globs stack)])) + (decompile-expr form globs stack closed)])) (define (extract-name name) (if (symbol? name) @@ -168,22 +169,22 @@ (extract-ids! body ids)] [else #f])) -(define (decompile-expr expr globs stack) +(define (decompile-expr expr globs stack closed) (match expr [(struct toplevel (depth pos const? mutated?)) - (let ([id (list-ref/protect globs pos)]) + (let ([id (list-ref/protect globs pos 'toplevel)]) (if const? id `(#%checked ,id)))] [(struct topsyntax (depth pos midpt)) - (list-ref/protect globs (+ midpt pos))] + (list-ref/protect globs (+ midpt pos) 'topsyntax)] [(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))] + `(set! ,(decompile-expr id globs stack closed) + ,(decompile-expr rhs globs stack closed))] [(struct localref (unbox? offset clear?)) - (let ([id (list-ref/protect stack offset)]) + (let ([id (list-ref/protect stack offset 'localref)]) (let ([e (if unbox? `(#%unbox ,id) id)]) @@ -191,17 +192,17 @@ `(#%sfs-clear ,e) e)))] [(? lam?) - `(lambda . ,(decompile-lam expr globs stack))] + `(lambda . ,(decompile-lam expr globs stack closed))] [(struct case-lam (name lams)) `(case-lambda ,@(map (lambda (lam) - (decompile-lam lam globs stack)) + (decompile-lam lam globs stack closed)) lams))] [(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))))] + `(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) @@ -210,71 +211,76 @@ (or id (gensym 'localv)))]) `(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)]) vars) - ,(decompile-expr body globs (append vars stack)))))] + ,(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)) + (list-ref/protect stack i 'let-rec)) ,@(map (lambda (proc) - (decompile-expr proc globs stack)) + (decompile-expr proc globs stack closed)) procs)) - ,(decompile-expr body globs stack))] + ,(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))) - ,(decompile-expr rhs globs stack)) - ,(decompile-expr body globs stack))] + (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)]) + (let ([id (list-ref/protect stack pos 'boxenv)]) `(begin (set! ,id (#%box ,id)) - ,(decompile-expr body globs stack)))] + ,(decompile-expr body globs stack closed)))] [(struct branch (test then else)) - `(if ,(decompile-expr test globs stack) - ,(decompile-expr then globs stack) - ,(decompile-expr else globs stack))] + `(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-inline - `(,(decompile-expr rator globs stack) + `(,(decompile-expr rator globs stack closed) ,@(map (lambda (rand) - (decompile-expr rand globs stack)) + (decompile-expr rand globs stack closed)) rands))))] [(struct apply-values (proc args-expr)) - `(#%apply-values ,(decompile-expr proc globs stack) - ,(decompile-expr args-expr globs stack))] + `(#%apply-values ,(decompile-expr proc globs stack closed) + ,(decompile-expr args-expr globs stack closed))] [(struct sequence (exprs)) `(begin ,@(for/list ([expr (in-list exprs)]) - (decompile-expr expr globs stack)))] + (decompile-expr expr globs stack closed)))] [(struct beg0 (exprs)) `(begin0 ,@(for/list ([expr (in-list exprs)]) - (decompile-expr expr globs stack)))] + (decompile-expr expr globs stack closed)))] [(struct with-cont-mark (key val body)) `(with-continuation-mark - ,(decompile-expr key globs stack) - ,(decompile-expr val globs stack) - ,(decompile-expr body globs stack))] + ,(decompile-expr key globs stack closed) + ,(decompile-expr val globs stack closed) + ,(decompile-expr body globs stack closed))] [(struct closure (lam gen-id)) - `(#%closed ,gen-id ,(decompile-expr lam globs stack))] + (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))))] [(struct indirect (val)) (if (closure? val) - (closure-gen-id val) + (decompile-expr val globs stack closed) '???)] [else `(quote ,expr)])) -(define (decompile-lam expr globs stack) +(define (decompile-lam expr globs stack closed) (match expr - [(struct closure (lam gen-id)) (decompile-lam lam globs stack)] + [(struct indirect (val)) (decompile-lam val globs stack closed)] + [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)] [(struct lam (name flags num-params rest? closure-map max-let-depth body)) (let ([vars (for/list ([i (in-range num-params)]) (gensym (format "arg~a-" i)))] [rest-vars (if rest? (list (gensym 'rest)) null)] [captures (map (lambda (v) - (list-ref/protect stack v)) + (list-ref/protect stack v 'lam)) (vector->list closure-map))]) `((,@vars . ,(if rest? (car rest-vars) @@ -285,8 +291,10 @@ ,@(if (null? captures) null `('(captures: ,@captures))) - ,(decompile-expr body globs (append captures - (append vars rest-vars)))))])) + ,(decompile-expr body globs + (append captures + (append vars rest-vars)) + closed)))])) (define (annotate-inline a) (if (and (symbol? (car a)) @@ -301,16 +309,16 @@ car cdr caar cadr cdar cddr mcar mcdr unbox vector-length syntax-e add1 sub1 - abs bitwise-not - list vector box))] + list list* vector vector-immutable box))] [(3) (memq (car a) '(eq? = <= < >= > bitwise-bit-set? char=? + - * / min max bitwise-and bitwise-ior arithmetic-shift vector-ref string-ref bytes-ref set-mcar! set-mcdr! cons mcons - list vector))] + list list* vector vector-immutable))] [(4) (memq (car a) '(vector-set! string-set! bytes-set! - list vector))] - [else (memq (car a) '(list vector))])) + list list* vector vector-immutable))] + [else (memq (car a) '(list list* vector vector-immutable))])) (cons '#%in a) a)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index a19caea4ad..57472a6c38 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -661,7 +661,7 @@ ;; Main parsing loop (define (read-compact cp) - (let loop ([need-car 0] [proper #f] [last #f] [first #f]) + (let loop ([need-car 0] [proper #f]) (begin-with-definitions (define ch (cp-getc cp)) (define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)]) @@ -707,7 +707,7 @@ (cons (read-compact cp) (if ppr null (read-compact cp))) (read-compact-list l ppr cp)) - (loop l ppr last first)))] + (loop l ppr)))] [(let-one) (make-let-one (read-compact cp) (read-compact cp))] [(branch) @@ -747,8 +747,10 @@ (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)))] + (append + (for/list ([i (in-range n)]) + (read-compact cp)) + (read-compact cp)))] [(prefab) (let ([v (read-compact cp)]) (apply make-prefab-struct @@ -845,9 +847,8 @@ [(symbol? s) s] [(vector? s) (vector-ref s 0)] [else 'closure]))))]) - (vector-set! (cport-symtab cp) l cl) (set-indirect-v! ind cl) - cl))] + ind))] [(svector) (read-compact-svector cp (read-compact-number cp))] [(small-svector) @@ -858,7 +859,7 @@ [(and proper (= need-car 1)) (cons v null)] [else - (cons v (loop (sub1 need-car) proper last first))])))) + (cons v (loop (sub1 need-car) proper))])))) ;; path -> bytes ;; implementes read.c:read_compiled @@ -898,11 +899,13 @@ (define symtab (make-vector symtabsize (make-not-ready))) (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) + (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)))