From 87373a2e0c3b1dbbeefc9ed9891fbe0e2a865952 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 5 May 2011 20:52:23 -0600 Subject: [PATCH] reorgnize datatypes of less common bytecode forms removing a layer of indirection, and setting up for an internal reorganization of the compiler code original commit: e9721058fb50e1dc38c0015ce89ac737d46ba462 --- collects/compiler/zo-marshal.rkt | 326 ++++++++++++++----------------- collects/compiler/zo-parse.rkt | 77 ++++---- 2 files changed, 180 insertions(+), 223 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 91380a3e51..ced39b755c 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -149,21 +149,29 @@ ;; ---------------------------------------- (define toplevel-type-num 0) -(define syntax-type-num 3) -(define sequence-type-num 7) -(define unclosed-procedure-type-num 9) -(define let-value-type-num 10) -(define let-void-type-num 11) -(define letrec-type-num 12) -(define wcm-type-num 14) -(define quote-syntax-type-num 15) -(define variable-type-num 24) -(define top-type-num 89) -(define case-lambda-sequence-type-num 99) -(define begin0-sequence-type-num 100) -(define module-type-num 103) -(define prefix-type-num 105) -(define free-id-info-type-num 154) +(define sequence-type-num 6) +(define unclosed-procedure-type-num 8) +(define let-value-type-num 9) +(define let-void-type-num 10) +(define letrec-type-num 11) +(define wcm-type-num 13) +(define quote-syntax-type-num 14) +(define define-values-type-num 15) +(define define-syntaxes-type-num 16) +(define define-for-syntax-type-num 17) +(define set-bang-type-num 18) +(define boxenv-type-num 19) +(define begin0-sequence-type-num 20) +(define splice-sequence-type-num 21) +(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 variable-type-num 34) +(define top-type-num 99) +(define prefix-type-num 112) +(define free-id-info-type-num 161) (define-syntax define-enum (syntax-rules () @@ -212,21 +220,6 @@ CPT_PREFAB CPT_LET_ONE_UNUSED) -(define-enum - 0 - DEFINE_VALUES_EXPD - DEFINE_SYNTAX_EXPD - SET_EXPD - CASE_LAMBDA_EXPD - BEGIN0_EXPD - BOXENV_EXPD - MODULE_EXPD - REQUIRE_EXPD - DEFINE_FOR_SYNTAX_EXPD - REF_EXPD - APPVALS_EXPD - SPLICE_EXPD) - (define CPT_SMALL_NUMBER_START 36) (define CPT_SMALL_NUMBER_END 60) @@ -271,10 +264,6 @@ #f #f)) -(define-struct case-seq (name lams)) -(define-struct (seq0 seq) ()) - - (define (encode-module-bindings module-bindings) (define encode-nominal-path (match-lambda @@ -440,9 +429,6 @@ (out-byte #xF0 out) (out-bytes (int->bytes n) out)])) -(define (out-syntax key val out) - (out-marshaled syntax-type-num (list* key val) out)) - (define (out-marshaled type-num val out) (if (type-num . < . (- CPT_SMALL_MARSHALLED_END CPT_SMALL_MARSHALLED_START)) (out-byte (+ CPT_SMALL_MARSHALLED_START type-num) out) @@ -541,34 +527,34 @@ [(? mod?) (out-module v out)] [(struct def-values (ids rhs)) - (out-syntax DEFINE_VALUES_EXPD - (list->vector (cons (protect-quote rhs) ids)) - out)] + (out-marshaled define-values-type-num + (list->vector (cons (protect-quote rhs) ids)) + out)] [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (out-syntax DEFINE_SYNTAX_EXPD - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - *dummy* - ids)) - out)] + (out-marshaled define-syntaxes-type-num + (list->vector (list* (protect-quote rhs) + prefix + max-let-depth + *dummy* + ids)) + out)] [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (out-syntax DEFINE_FOR_SYNTAX_EXPD - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - *dummy* - ids)) - out)] - [(struct seq0 (forms)) + (out-marshaled define-for-syntax-type-num + (list->vector (list* (protect-quote rhs) + prefix + max-let-depth + *dummy* + ids)) + out)] + [(struct beg0 (forms)) (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] [(struct seq (forms)) (out-marshaled sequence-type-num (map protect-quote forms) out)] [(struct splice (forms)) - (out-syntax SPLICE_EXPD (make-seq forms) out)] + (out-marshaled splice-sequence-type-num forms out)] [(struct req (reqs dummy)) (error "cannot handle top-level `require', yet") - (out-syntax REQUIRE_EXPD (cons dummy reqs) out)] + (out-marshaled require-form-type-num (cons dummy reqs) out)] [(struct toplevel (depth pos const? ready?)) (out-marshaled toplevel-type-num (cons @@ -589,9 +575,9 @@ (out-byte CPT_REFERENCE out) (out-number id out)] [(struct assign (id rhs undef-ok?)) - (out-syntax SET_EXPD - (cons undef-ok? (cons id rhs)) - out)] + (out-marshaled set-bang-type-num + (cons undef-ok? (cons id rhs)) + out)] [(struct localref (unbox? offset clear? other-clears? flonum?)) (if (and (not clear?) (not other-clears?) (not flonum?) (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) @@ -617,19 +603,6 @@ [(? lam?) (out-lam v out)] [(struct case-lam (name lams)) - (let ([seq (make-case-seq name lams)]) - ;; XXX: This seems like an optimization, which should probably happen somewhere else - ;; If all closures are empty, generate a case sequence directly - (if (andmap (lambda (lam) - (or (closure? lam) - (and (lam? lam) - (equal? (lam-closure-map lam) #())))) - lams) - (out-anything seq out) - (out-syntax CASE_LAMBDA_EXPD - seq - out)))] - [(struct case-seq (name lams)) (out-marshaled case-lambda-sequence-type-num (cons (or name null) lams) @@ -666,11 +639,11 @@ (protect-quote body)) out)] [(struct boxenv (pos body)) - (out-syntax BOXENV_EXPD - (cons - pos - (protect-quote body)) - out)] + (out-marshaled boxenv-type-num + (cons + pos + (protect-quote body)) + out)] [(struct branch (test then else)) (out-byte CPT_BRANCH out) (out-anything (protect-quote test) out) @@ -687,14 +660,10 @@ (out-anything (protect-quote e) out)) (cons rator rands)))] [(struct apply-values (proc args-expr)) - (out-syntax APPVALS_EXPD - (cons (protect-quote proc) - (protect-quote args-expr)) - out)] - [(struct beg0 (exprs)) - (out-syntax BEGIN0_EXPD - (make-seq0 exprs) - out)] + (out-marshaled apply-values-type-num + (cons (protect-quote proc) + (protect-quote args-expr)) + out)] [(struct with-cont-mark (key val body)) (out-marshaled wcm-type-num (list* @@ -703,9 +672,9 @@ (protect-quote body)) out)] [(struct varref (expr)) - (out-syntax REF_EXPD - expr - out)] + (out-marshaled varref-form-type-num + expr + out)] [(protected-symref v) (out-anything ((out-shared-index out) v #:error? #t) out)] [(and (? symbol?) (not (? symbol-interned?))) @@ -823,10 +792,6 @@ (let-values ([(name base) (module-path-index-split v)]) (out-anything name out) (out-anything base out))] - [(module-decl content) - (out-marshaled module-type-num - content - out)] [(stx encoded) (out-byte CPT_STX out) (out-anything encoded out)] @@ -866,99 +831,96 @@ (out-bytes bstr out)] [else (error 'out-anything "~s" (current-type-trace))]))))) -(define-struct module-decl (content)) - (define (out-module mod-form out) (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context)) - (out-syntax MODULE_EXPD - (let* ([lookup-req (lambda (phase) - (let ([a (assq phase requires)]) - (if a - (cdr a) - null)))] - [other-requires (filter (lambda (l) - (not (memq (car l) '(#f -1 0 1)))) - requires)] - [extract-protects - (lambda (phase) - (let ([a (assq phase provides)]) - (and a - (let ([p (map provided-protected? (append (cadr a) - (caddr a)))]) - (if (ormap values p) - (list->vector p) - #f)))))] - [list->vector/#f (lambda (default l) - (if (andmap (lambda (x) (equal? x default)) l) - #f - (list->vector l)))] - [l - (let loop ([l other-requires]) - (match l - [(list) - empty] - [(list-rest (cons phase reqs) rst) - (list* phase reqs (loop rst))]))] - [l (cons (length other-requires) l)] - [l (cons (lookup-req #f) l)] ; dt-requires - [l (cons (lookup-req -1) l)] ; tt-requires - [l (cons (lookup-req 1) l)] ; et-requires - [l (cons (lookup-req 0) l)] ; requires - [l (cons (list->vector body) l)] - [l (cons (list->vector - (for/list ([i (in-list syntax-body)]) - (define (maybe-one l) ;; a single symbol is ok - (if (and (pair? l) (null? (cdr l))) - (car l) - l)) - (match i - [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (vector (maybe-one ids) rhs max-let-depth prefix #f)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (vector (maybe-one ids) rhs max-let-depth prefix #t)]))) - l)] - [l (append (apply - append - (map (lambda (l) - (let ([phase (car l)] - [all (append (cadr l) (caddr l))]) - (list phase - (list->vector/#f #f (map provided-insp all)) - (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) - all)) - (list->vector/#f #f (map (lambda (p) - (if (eq? (provided-nom-src p) - (provided-src p)) - #f ; #f means "same as src" - (provided-nom-src p))) - all)) - (list->vector (map provided-src-name all)) - (list->vector (map provided-src all)) - (list->vector (map provided-name all)) - (length (cadr l)) - (length all)))) - provides)) - l)] - [l (cons (length provides) l)] ; number of provide sets - [l (cons (extract-protects 0) l)] ; protects - [l (cons (extract-protects 1) l)] ; et protects - [l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides - [l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides - [l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides - [l (cons prefix l)] - [l (cons dummy l)] - [l (cons max-let-depth l)] - [l (cons internal-context l)] ; module->namespace syntax - [l (list* #f #f l)] ; obsolete `functional?' info - [l (cons lang-info l)] ; lang-info - [l (cons self-modidx l)] - [l (cons srcname l)] - [l (cons name l)]) - (make-module-decl l)) - out)])) - + (let* ([lookup-req (lambda (phase) + (let ([a (assq phase requires)]) + (if a + (cdr a) + null)))] + [other-requires (filter (lambda (l) + (not (memq (car l) '(#f -1 0 1)))) + requires)] + [extract-protects + (lambda (phase) + (let ([a (assq phase provides)]) + (and a + (let ([p (map provided-protected? (append (cadr a) + (caddr a)))]) + (if (ormap values p) + (list->vector p) + #f)))))] + [list->vector/#f (lambda (default l) + (if (andmap (lambda (x) (equal? x default)) l) + #f + (list->vector l)))] + [l + (let loop ([l other-requires]) + (match l + [(list) + empty] + [(list-rest (cons phase reqs) rst) + (list* phase reqs (loop rst))]))] + [l (cons (length other-requires) l)] + [l (cons (lookup-req #f) l)] ; dt-requires + [l (cons (lookup-req -1) l)] ; tt-requires + [l (cons (lookup-req 1) l)] ; et-requires + [l (cons (lookup-req 0) l)] ; requires + [l (cons (list->vector body) l)] + [l (cons (list->vector + (for/list ([i (in-list syntax-body)]) + (define (maybe-one l) ;; a single symbol is ok + (if (and (pair? l) (null? (cdr l))) + (car l) + l)) + (match i + [(struct def-syntaxes (ids rhs prefix max-let-depth)) + (vector (maybe-one ids) rhs max-let-depth prefix #f)] + [(struct def-for-syntax (ids rhs prefix max-let-depth)) + (vector (maybe-one ids) rhs max-let-depth prefix #t)]))) + l)] + [l (append (apply + append + (map (lambda (l) + (let ([phase (car l)] + [all (append (cadr l) (caddr l))]) + (list phase + (list->vector/#f #f (map provided-insp all)) + (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) + all)) + (list->vector/#f #f (map (lambda (p) + (if (eq? (provided-nom-src p) + (provided-src p)) + #f ; #f means "same as src" + (provided-nom-src p))) + all)) + (list->vector (map provided-src-name all)) + (list->vector (map provided-src all)) + (list->vector (map provided-name all)) + (length (cadr l)) + (length all)))) + provides)) + l)] + [l (cons (length provides) l)] ; number of provide sets + [l (cons (extract-protects 0) l)] ; protects + [l (cons (extract-protects 1) l)] ; et protects + [l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides + [l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides + [l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides + [l (cons prefix l)] + [l (cons dummy l)] + [l (cons max-let-depth l)] + [l (cons internal-context l)] ; module->namespace syntax + [l (list* #f #f l)] ; obsolete `functional?' info + [l (cons lang-info l)] ; lang-info + [l (cons self-modidx l)] + [l (cons srcname l)] + [l (cons name l)]) + (out-marshaled module-type-num + l + out))])) (define (lookup-encoded-wrapped w out) (hash-ref! (out-encoded-wraps out) w diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 7f8770ee44..a0f156aeac 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -200,9 +200,7 @@ (make-case-lam (car v) (cdr v))) (define (read-begin0 v) - (match v - [(struct seq (exprs)) - (make-beg0 exprs)])) + (make-beg0 v)) (define (read-boxenv v) (make-boxenv (car v) (cdr v))) @@ -213,7 +211,7 @@ (define (read-apply-values v) (make-apply-values (car v) (cdr v))) (define (read-splice v) - (make-splice (seq-forms v))) + (make-splice v)) (define (in-list* l n) (make-do-sequence @@ -303,51 +301,39 @@ ;; ---------------------------------------- ;; 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) v] ; a case-lam already - [(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] - [(25) 'module-variable-type] - [(99) 'case-lambda-sequence-type] - [(100) 'begin0-sequence-type] - [(103) 'module-type] - [(105) 'resolve-prefix-type] - [(154) 'free-id-info-type] + [(6) 'sequence-type] + [(8) 'unclosed-procedure-type] + [(9) 'let-value-type] + [(10) 'let-void-type] + [(11) 'letrec-type] + [(13) 'with-cont-mark-type] + [(14) 'quote-syntax-type] + [(15) 'define-values-type] + [(16) 'define-syntaxes-type] + [(17) 'define-for-syntax-type] + [(18) 'set-bang-type] + [(19) 'boxenv-type] + [(20) 'begin0-sequence-type] + [(21) 'splice-sequence-type] + [(22) 'require-form-type] + [(23) 'varref-form-type] + [(24) 'apply-values-type] + [(25) 'case-lambda-sequence-type] + [(26) 'module-type] + [(34) 'variable-type] + [(35) 'module-variable-type] + [(112) 'resolve-prefix-type] + [(161) 'free-id-info-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) @@ -359,10 +345,19 @@ (cons 'module-variable-type do-not-read-variable) (cons 'compilation-top-type read-compilation-top) (cons 'case-lambda-sequence-type read-case-lambda) - (cons 'begin0-sequence-type read-sequence) + (cons 'begin0-sequence-type read-begin0) (cons 'module-type read-module) (cons 'resolve-prefix-type read-resolve-prefix) - (cons 'free-id-info-type read-free-id-info)))) + (cons 'free-id-info-type read-free-id-info) + (cons 'define-values-type read-define-values) + (cons 'define-syntaxes-type read-define-syntax) + (cons 'define-for-syntax-type read-define-for-syntax) + (cons 'set-bang-type read-set!) + (cons 'boxenv-type read-boxenv) + (cons 'require-form-type read-require) + (cons 'varref-form-type read-#%variable-ref) + (cons 'apply-values-type read-apply-values) + (cons 'sequence-splice-type read-splice)))) (define (get-reader type) (hash-ref type-readers type