diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index cef5601613..23a9b70652 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -1,6 +1,7 @@ -#lang scheme +#lang scheme/base (require compiler/zo-parse - syntax/modcollapse) + syntax/modcollapse + scheme/match) (provide decompile) @@ -146,7 +147,7 @@ (define (extract-id expr) (match expr - [(struct lam (name flags num-params rest? closure-map max-let-depth body)) + [(struct lam (name flags num-params arg-types rest? closure-map max-let-depth body)) (extract-name name)] [(struct case-lam (name lams)) (extract-name name)] @@ -184,7 +185,7 @@ [(struct assign (id rhs undef-ok?)) `(set! ,(decompile-expr id globs stack closed) ,(decompile-expr rhs globs stack closed))] - [(struct localref (unbox? offset clear?)) + [(struct localref (unbox? offset clear? other-clears?)) (let ([id (list-ref/protect stack offset 'localref)]) (let ([e (if unbox? `(#%unbox ,id) @@ -276,9 +277,12 @@ (match expr [(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)))] + [(struct lam (name flags num-params arg-types rest? closure-map max-let-depth body)) + (let ([vars (for/list ([i (in-range num-params)] + [type (in-list arg-types)]) + (gensym (format "~a~a-" + (if (eq? type 'ref) "argbox" "arg") + i)))] [rest-vars (if rest? (list (gensym 'rest)) null)] [captures (map (lambda (v) (list-ref/protect stack v 'lam)) diff --git a/collects/compiler/write-bytecode.ss b/collects/compiler/write-bytecode.ss new file mode 100644 index 0000000000..a37b768341 --- /dev/null +++ b/collects/compiler/write-bytecode.ss @@ -0,0 +1,679 @@ +#lang scheme/base +(require compiler/zo-parse + scheme/match) + +(provide write-bytecode) + +;; Doesn't write as compactly as MzScheme, since list and pair sequences +;; are not compated, and symbols are not written in short form + +(define (write-bytecode top) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (let ([encountered (make-hasheq)] + [shared (make-hasheq)]) + (let ([visit (lambda (v) + (if (hash-ref shared v) + #f + (if (hash-ref encountered v #f) + (begin + (hash-set! shared v (hash-count shared)) + #f) + (begin + (hash-set! encountered v #t) + #t))))]) + (traverse-prefix prefix visit) + (traverse-form form visit)) + (let* ([s (open-output-bytes)] + [out (make-out s (lambda (v) (hash-ref shared v #f)))] + [offsets + (map (lambda (v) + (begin0 + (file-position s) + (out-anything v (make-out + s + (let ([skip? #f]) + (lambda (v2) + (if (and (not skip?) (eq? v v2)) + (begin + (set! skip? #t) + #f) + (hash-ref shared v2 #f)))))))) + (sort (hash-map shared (lambda (k v) (cons v k))) + < + #:key car))] + [post-shared (file-position s)] + [all-short? (post-shared . < . #xFFFF)]) + (out-data (list* max-let-depth prefix (protect-quote form)) out) + (let ([res (get-output-bytes s)]) + (bytes-append #"#~" + (bytes (string-length (version))) + (string->bytes/latin-1 (version)) + (int->bytes (add1 (hash-count shared))) + (bytes (if all-short? + 1 + 0)) + (apply + bytes-append + (map (lambda (o) + (integer->integer-bytes o + (if all-short? 2 4) + #f + #f)) + offsets)) + (int->bytes post-shared) + (int->bytes (bytes-length res)) + res))))])) + +;; ---------------------------------------- + +(define (traverse-prefix a-prefix visit) + (match a-prefix + [(struct prefix (num-lifts toplevels stxs)) + (for-each (lambda (stx) (traverse-toplevel stx visit)) stxs) + (for-each (lambda (stx) (traverse-stx stx visit)) stxs)])) + +(define (traverse-module mod-form visit) + (match mod-form + [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) + (error "cannot handle modules, yet") + (traverse-data name visit) + (traverse-data self-modidx visit) + (traverse-prefix prefix visit) + (for-each (lambda (f) (traverse-form f prefix)) body) + (for-each (lambda (f) (traverse-form f prefix)) syntax-body)])) + +(define (traverse-toplevel tl visit) + (match tl + [#f (void)] + [(? symbol?) (visit tl)] + [(struct global-bucket (name)) + (void)] + [(struct module-variable (modidx sym pos phase)) + (visit tl) + (let-values ([(p b) (module-path-index-split modidx)]) + (if (symbol? p) + (traverse-data p visit) + (traverse-data modidx visit))) + (traverse-data sym visit)])) + +(define (traverse-stx tl visit) + (error "cannot handle syntax objects, yet")) + +(define (traverse-form form visit) + (match form + [(? mod?) + (traverse-module form visit)] + [(struct def-values (ids rhs)) + (traverse-expr rhs visit)] + [(struct def-syntaxes (ids rhs prefix max-let-depth)) + (traverse-prefix prefix visit) + (traverse-expr rhs visit)] + [(struct def-for-syntax (ids rhs prefix max-let-depth)) + (traverse-prefix prefix visit) + (traverse-expr rhs visit)] + [(struct seq (forms)) + (for-each (lambda (f) (traverse-form f visit)) forms)] + [(struct splice (forms)) + (for-each (lambda (f) (traverse-form f visit)) forms)] + [else + (traverse-expr form visit)])) + +(define (traverse-expr expr visit) + (match expr + [(struct toplevel (depth pos const? ready?)) + (void)] + [(struct topsyntax (depth pos midpt)) + (void)] + [(struct primval (id)) + (void)] + [(struct assign (id rhs undef-ok?)) + (traverse-expr rhs)] + [(struct localref (unbox? offset clear? other-clears?)) + (void)] + [(? lam?) + (traverse-lam expr visit)] + [(struct case-lam (name lams)) + (traverse-data name visit) + (for-each (lambda (lam) (traverse-lam expr visit)) lams)] + [(struct let-one (rhs body)) + (traverse-expr rhs visit) + (traverse-expr body visit)] + [(struct let-void (count boxes? body)) + (traverse-expr body visit)] + [(struct let-rec (procs body)) + (for-each (lambda (lam) (traverse-lam lam visit)) procs) + (traverse-expr body visit)] + [(struct install-value (count pos boxes? rhs body)) + (traverse-expr rhs visit) + (traverse-expr body visit)] + [(struct boxenv (pos body)) + (traverse-expr body visit)] + [(struct branch (test then else)) + (traverse-expr test visit) + (traverse-expr then visit) + (traverse-expr else visit)] + [(struct application (rator rands)) + (traverse-expr rator visit) + (for-each (lambda (rand) (traverse-expr rand visit)) rands)] + [(struct apply-values (proc args-expr)) + (traverse-expr proc visit) + (traverse-expr args-expr visit)] + [(struct seq (exprs)) + (for-each (lambda (expr) (traverse-expr expr visit)) exprs)] + [(struct beg0 (exprs)) + (for-each (lambda (expr) (traverse-expr expr visit)) exprs)] + [(struct with-cont-mark (key val body)) + (traverse-expr key visit) + (traverse-expr val visit) + (traverse-expr body visit)] + [(struct closure (lam gen-id)) + (traverse-lam expr visit)] + [(struct indirect (val)) + (traverse-expr val visit)] + [else (traverse-data expr visit)])) + +(define (traverse-data expr visit) + (cond + [(or (symbol? expr) + (keyword? expr) + (string? expr) + (bytes? expr) + (path? expr) + (module-path-index? expr)) + (visit expr)] + [(pair? expr) + (traverse-data (car expr) visit) + (traverse-data (cdr expr) visit)] + [else (void)])) + +(define (traverse-lam expr visit) + (match expr + [(struct indirect (val)) (traverse-lam expr visit)] + [(struct closure (lam gen-id)) + (when (visit expr) + (traverse-lam expr visit))] + [(struct lam (name flags num-params param-types rest? closure-map max-let-depth body)) + (traverse-data name visit) + (traverse-expr body visit)])) + +;; ---------------------------------------- + +(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 87) +(define case-lambda-sequence-type-num 96) +(define prefix-type-num 103) + +(define-syntax define-enum + (syntax-rules () + [(_ n) (begin)] + [(_ n id . rest) + (begin + (define id n) + (define-enum (add1 n) . rest))])) + +(define-enum + 0 + CPT_ESCAPE + CPT_SYMBOL + CPT_SYMREF + CPT_WEIRD_SYMBOL + CPT_KEYWORD + CPT_BYTE_STRING + CPT_CHAR_STRING + CPT_CHAR + CPT_INT + CPT_NULL + CPT_TRUE + CPT_FALSE + CPT_VOID + CPT_BOX + CPT_PAIR + CPT_LIST + CPT_VECTOR + CPT_HASH_TABLE + CPT_STX + CPT_GSTX + CPT_MARSHALLED + CPT_QUOTE + CPT_REFERENCE + CPT_LOCAL + CPT_LOCAL_UNBOX + CPT_SVECTOR + CPT_APPLICATION + CPT_LET_ONE + CPT_BRANCH + CPT_MODULE_INDEX + CPT_MODULE_VAR + CPT_PATH + CPT_CLOSURE + CPT_DELAY_REF + CPT_PREFAB) + +(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_LOCAL_START 192) +(define CPT_SMALL_LOCAL_END 207) +(define CPT_SMALL_LOCAL_UNBOX_START 207) +(define CPT_SMALL_LOCAL_UNBOX_END 222) + +(define CPT_SMALL_APPLICATION_START 247) +(define CPT_SMALL_APPLICATION_END 255) + +(define CLOS_HAS_REST 1) +(define CLOS_HAS_REF_ARGS 2) +(define CLOS_PRESERVES_MARKS 4) +(define CLOS_IS_METHOD 16) +(define CLOS_SINGLE_RESULT 32) + +(define BITS_PER_MZSHORT 32) + +(define *dummy* #f) + +(define (int->bytes x) + (integer->integer-bytes x + 4 + #f + #f)) + +(define-struct case-seq (name lams)) + +(define-struct out (s shared-index)) + +(define (out-shared v out k) + (let ([v ((out-shared-index out) v)]) + (if v + (begin + (out-byte CPT_SYMREF out) + (out-number v out)) + (k)))) + +(define (out-byte v out) + (write-byte v (out-s out))) + +(define (out-bytes b out) + (write-bytes b (out-s out))) + +(define (out-number n out) + (cond + [(n . < . 0) + (if (n . > . -32) + (out-byte (bitwise-ior #xC0 (- n)) out) + (begin + (out-byte #xE0 out) + (out-bytes (int->bytes (- n)) out)))] + [(n . < . 128) + (out-byte n out)] + [(n . < . #x4000) + (out-byte (bitwise-ior #x80 (bitwise-and n #x3F)) out) + (out-byte (bitwise-and #xFF (arithmetic-shift n -6)) out)] + [else + (out-bytes #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) + (out-byte CPT_MARSHALLED out) + (out-number type-num out) + (out-data val out)) + +(define (out-anything v out) + (cond + [(module-variable? v) + (out-toplevel v out)] + [(closure? v) + (out-expr v out)] + [else + (out-data v out)])) + +(define (out-prefix a-prefix out) + (match a-prefix + [(struct prefix (num-lifts toplevels stxs)) + (out-marshaled + prefix-type-num + (cons num-lifts + (cons (list->vector toplevels) + (list->vector stxs))) + out)])) + +(define (out-module mod-form out) + (match mod-form + [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) + (error "cannot write modules, yet")])) + +(define (out-toplevel tl out) + (match tl + [#f (out-data tl out)] + [(? symbol?) (out-data tl out)] + [(struct global-bucket (name)) + (out-marshaled variable-type-num name out)] + [(struct module-variable (modidx sym pos phase)) + (out-shared + tl + out + (lambda () + (out-byte CPT_MODULE_VAR out) + (let-values ([(p b) (module-path-index-split modidx)]) + (if (symbol? p) + (out-data p out) + (out-data modidx out))) + (out-data sym out) + (unless (zero? phase) + (out-number -2 out)) + (out-number pos out)))])) + +(define (out-stx tl out) + (error "cannot handle syntax objects, yet")) + +(define (out-form form out) + (match form + [(? mod?) + (out-module form out)] + [(struct def-values (ids rhs)) + (out-syntax DEFINE_VALUES_EXPD + (list->vector (cons rhs ids)) + out)] + [(struct def-syntaxes (ids rhs prefix max-let-depth)) + (out-syntax DEFINE_SYNTAX_EXPD + (list->vector (list* 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* rhs + prefix + max-let-depth + *dummy* + ids)) + 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)] + [else + (out-expr form out)])) + +(define (out-expr expr out) + (match expr + [(struct toplevel (depth pos const? ready?)) + (out-marshaled toplevel-type-num + (if (or const? ready?) + (cons pos + (bitwise-ior + (if const? #x1 0) + (if ready? #x2 0))) + pos) + out)] + [(struct topsyntax (depth pos midpt)) + (out-marshaled quote-syntax-type-num + (cons depth + (cons pos midpt)) + out)] + [(struct primval (id)) + (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)] + [(struct localref (unbox? offset clear? other-clears?)) + (if (and (not clear?) (not other-clears?) + (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) + (out-byte (+ (if unbox? + CPT_SMALL_LOCAL_UNBOX_START + CPT_SMALL_LOCAL_START) + offset) + out) + (begin + (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) + (if (not (or clear? other-clears?)) + (out-number offset out) + (begin + (out-number (- (add1 offset)) out) + (out-number (+ (if clear? #x1 0) + (if other-clears? #x2 0)) + out)))))] + [(? lam?) + (out-lam expr out)] + [(struct case-lam (name lams)) + (out-syntax CASE_LAMBDA_EXPD + (make-case-seq name lams))] + [(struct case-seq (name lams)) + (out-marshaled case-lambda-sequence-type-num + (cons (or name null) + lams) + out)] + [(struct let-one (rhs body)) + (out-byte CPT_LET_ONE out) + (out-expr (protect-quote rhs) out) + (out-expr (protect-quote body) out)] + [(struct let-void (count boxes? body)) + (out-marshaled let-void-type-num + (list* + count + boxes? + (protect-quote body)) + out)] + [(struct let-rec (procs body)) + (out-marshaled letrec-type-num + (list* + (length procs) + (protect-quote body) + procs) + out)] + [(struct install-value (count pos boxes? rhs body)) + (out-marshaled let-value-type-num + (list* + count + pos + boxes? + (protect-quote rhs) + (protect-quote body)) + out)] + [(struct boxenv (pos body)) + (out-syntax BOXENV_EXPD + (cons + pos + (protect-quote body)) + out)] + [(struct branch (test then else)) + (out-byte CPT_BRANCH out) + (out-expr (protect-quote test) out) + (out-expr (protect-quote then) out) + (out-expr (protect-quote else) out)] + [(struct application (rator rands)) + (if ((length rands) . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START)) + (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out) + (begin + (out-byte CPT_APPLICATION out) + (out-number (length rands) out))) + (for-each (lambda (e) (out-expr (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 seq (exprs)) + (out-form expr out)] + [(struct beg0 (exprs)) + (out-syntax BEGIN0_EXPD + (make-seq exprs) + out)] + [(struct with-cont-mark (key val body)) + (out-marshaled wcm-type-num + (list* + (protect-quote key) + (protect-quote val) + (protect-quote body)) + out)] + [(struct closure (lam gen-id)) + (out-lam expr out)] + [(struct indirect (val)) + (out-expr val out)] + [else (out-value expr out)])) + +(define (out-lam expr out) + (match expr + [(struct indirect (val)) (out-lam expr out)] + [(struct closure (lam gen-id)) + (out-shared + expr + out + (lambda () + (out-lam expr out)))] + [(struct lam (name flags num-params param-types rest? closure-map max-let-depth body)) + (let* ([l (protect-quote body)] + [any-refs? (ormap (lambda (t) (eq? t 'ref)) param-types)] + [l (cons (make-svector (if any-refs? + (list->vector + (append + (vector->list closure-map) + (let ([v (make-vector (ceiling (/ num-params BITS_PER_MZSHORT)))]) + (for ([t (in-list param-types)] + [i (in-naturals)]) + (when (eq? t 'ref) + (let ([pos (quotient i BITS_PER_MZSHORT)]) + (vector-set! v pos + (bitwise-ior (vector-ref v pos) + (arithmetic-shift 1 (modulo i BITS_PER_MZSHORT))))))) + (vector->list v)))) + closure-map)) + l)] + [l (if any-refs? + (cons (vector-length closure-map) l) + l)]) + (out-marshaled unclosed-procedure-type-num + (list* + (+ (if rest? CLOS_HAS_REST 0) + (if any-refs? CLOS_HAS_REF_ARGS 0) + (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) + (if (memq 'is-method flags) CLOS_IS_METHOD 0) + (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) + num-params + max-let-depth + name + l) + out))])) + +(define (out-as-bytes expr ->bytes CPT out) + (out-shared expr out (lambda () + (let ([s (->bytes expr)]) + (out-byte CPT out) + (out-number (bytes-length s) out) + (out-bytes s out))))) + +(define (out-data expr out) + (cond + [(prefix? expr) (out-prefix expr out)] + [else (out-form expr out)])) + +(define (out-value expr out) + (cond + [(symbol? expr) + (out-as-bytes expr + (compose string->bytes/utf-8 symbol->string) + CPT_SYMBOL + out)] + [(keyword? expr) + (out-as-bytes expr + (compose string->bytes/utf-8 keyword->string) + CPT_KEYWORD + out)] + [(string? expr) + (out-as-bytes expr + string->bytes/utf-8 + CPT_CHAR_STRING + out)] + [(bytes? expr) + (out-as-bytes expr + values + CPT_BYTE_STRING + out)] + [(path? expr) + (out-as-bytes expr + path->bytes + CPT_PATH + out)] + [(char? expr) + (out-byte CPT_CHAR out) + (out-number (char->integer expr) out)] + [(and (exact-integer? expr) + (and (expr . >= . -1073741824) (expr . <= . 1073741823))) + (out-byte CPT_INT out) + (out-number expr out)] + [(null? expr) + (out-byte CPT_NULL out)] + [(eq? expr #t) + (out-byte CPT_TRUE out)] + [(eq? expr #f) + (out-byte CPT_FALSE out)] + [(void? expr) + (out-byte CPT_VOID out)] + [(box? expr) + (out-byte CPT_BOX out) + (out-data (unbox expr) out)] + [(pair? expr) + (out-byte CPT_LIST out) + (out-number 1 out) + (out-data (car expr) out) + (out-data (cdr expr) out)] + [(vector? expr) + (out-byte CPT_VECTOR out) + (out-number (vector-length expr) out) + (for ([v (in-vector expr)]) + (out-data v out))] + [(hash? expr) + (out-byte CPT_HASH_TABLE out) + (out-number (cond + [(hash-eqv? expr) 2] + [(hash-eq? expr) 0] + [else 1])) + (for ([(k v) (in-hash expr)]) + (out-data k out) + (out-data v out))] + [(svector? expr) + (error "fixme svector")] + [else + (out-byte CPT_QUOTE out) + (let ([s (open-output-bytes)]) + (write (if (quoted? expr) (quoted-v expr) expr) s) + (out-bytes (get-output-bytes s) out))])) + +(define-struct quoted (v)) +(define (protect-quote v) + (if (or (list? v) (vector? v) (box? v) (hash? v)) + (make-quoted v) + v)) + +(define-struct svector (vec)) + +;; ---------------------------------------- + diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 6e4abbc12c..73d9d2de60 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -1,5 +1,6 @@ -#lang scheme +#lang scheme/base (require mzlib/etc + scheme/match scheme/list) (provide zo-parse) @@ -35,7 +36,7 @@ (define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body max-let-depth)) -(define-form-struct (lam expr) (name flags num-params rest? closure-map max-let-depth body)) ; `lambda' +(define-form-struct (lam expr) (name flags num-params param-types rest? closure-map max-let-depth body)) ; `lambda' (define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over) (define-form-struct (case-lam expr) (name clauses)) ; each clause is an lam @@ -45,7 +46,7 @@ (define-form-struct (let-rec expr) (procs body)) ; put `letrec'-bound closures into existing stack slots (define-form-struct (boxenv expr) (pos body)) ; box existing stack element -(define-form-struct (localref expr) (unbox? pos clear?)) ; access local via stack +(define-form-struct (localref expr) (unbox? pos clear? other-clears?)) ; access local via stack (define-form-struct (toplevel expr) (depth pos const? ready?)) ; access binding via prefix array (which is on stack) (define-form-struct (topsyntax expr) (depth pos midpt)) ; access syntax object via prefix array (which is on stack) @@ -115,16 +116,33 @@ (define (read-unclosed-procedure v) (define CLOS_HAS_REST 1) (define CLOS_HAS_REF_ARGS 2) + (define CLOS_PRESERVES_MARKS 4) + (define CLOS_IS_METHOD 16) + (define CLOS_SINGLE_RESULT 32) + (define BITS_PER_MZSHORT 32) (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 (vector-length v) v rest) - (values v (car rest) (cdr rest)))]) + (let*-values ([(closure-size closed-over body) + (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) + (values (vector-length v) v rest) + (values v (car rest) (cdr rest)))] + [(arg-types) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) + (for/list ([i (in-range num-params)]) 'val) + (for/list ([i (in-range num-params)]) + (if (bitwise-bit-set? + (vector-ref closed-over + (+ closure-size (quotient i BITS_PER_MZSHORT))) + (remainder i BITS_PER_MZSHORT)) + 'ref + 'val)))]) (make-lam name - flags + (append + (if (bitwise-and flags flags CLOS_PRESERVES_MARKS) '(preserves-marks) null) + (if (bitwise-and flags flags CLOS_IS_METHOD) '(is-method) null) + (if (bitwise-and flags flags CLOS_SINGLE_RESULT) '(single-result) null)) ((if rest? sub1 values) num-params) + arg-types rest? (if (= closure-size (vector-length closed-over)) closed-over @@ -428,7 +446,10 @@ (define (make-local unbox? pos flags) (define SCHEME_LOCAL_CLEAR_ON_READ #x01) - (make-localref unbox? pos (positive? (bitwise-and flags SCHEME_LOCAL_CLEAR_ON_READ)))) + (define SCHEME_LOCAL_OTHER_CLEARS #x02) + (make-localref unbox? pos + (positive? (bitwise-and flags SCHEME_LOCAL_CLEAR_ON_READ)) + (positive? (bitwise-and flags SCHEME_LOCAL_OTHER_CLEARS)))) (define (a . << . b) (arithmetic-shift a b))