From 84703417d7024c29e5fbace74ec945ee5221b1a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 3 Oct 2016 17:19:44 +0200 Subject: [PATCH] Ignore the extra zo fields added in 6.3, copy updated qq-and-or.rkt --- whalesong/lang/private/qq-and-or.rkt | 168 +++-- whalesong/parser/parse-bytecode-5.3.3.7.rkt | 3 +- whalesong/parser/parse-bytecode-6.3.rkt | 763 ++++++++++++++++++++ whalesong/parser/parse-bytecode.rkt | 9 +- 4 files changed, 882 insertions(+), 61 deletions(-) create mode 100644 whalesong/parser/parse-bytecode-6.3.rkt diff --git a/whalesong/lang/private/qq-and-or.rkt b/whalesong/lang/private/qq-and-or.rkt index 37bbf3d..56cfe63 100644 --- a/whalesong/lang/private/qq-and-or.rkt +++ b/whalesong/lang/private/qq-and-or.rkt @@ -5,19 +5,50 @@ (module qq-and-or '#%kernel (#%require (for-syntax "stx.rkt" '#%kernel)) - (define-syntaxes (let let* letrec) + (define-syntaxes (let*-values let let* letrec) (let-values ([(lambda-stx) (quote-syntax lambda-stx)] - [(letrec-values-stx) (quote-syntax letrec-values)]) + [(letrec-values-stx) (quote-syntax letrec-values)] + [(check-for-duplicates) + (lambda (new-bindings sel stx) + (define-values (id-in-list?) + (lambda (id l) + (if (null? l) + #f + (if (bound-identifier=? id (car l)) + #t + (id-in-list? id (cdr l)))))) + (if ((length new-bindings) . > . 5) + (let-values ([(ht) (make-hasheq)]) + (letrec-values ([(check) (lambda (l) + (if (null? l) + (void) + (let-values ([(id) (sel (car l))]) + (let-values ([(idl) (hash-ref ht (syntax-e id) null)]) + (if (id-in-list? id idl) + (raise-syntax-error + #f + "duplicate identifier" + stx + id) + (begin + (hash-set! ht (syntax-e id) (cons id idl)) + (check (cdr l))))))))]) + (check new-bindings))) + (letrec-values ([(check) (lambda (l accum) + (if (null? l) + (void) + (let-values ([(id) (sel (car l))]) + (if (id-in-list? id accum) + (raise-syntax-error + #f + "duplicate identifier" + stx + id) + (check (cdr l) (cons id accum))))))]) + (check new-bindings null))))]) (let-values ([(go) (lambda (stx named? star? target) (define-values (stx-cadr) (lambda (x) (stx-car (stx-cdr x)))) - (define-values (id-in-list?) - (lambda (id l) - (if (null? l) - #f - (if (bound-identifier=? id (car l)) - #t - (id-in-list? id (cdr l)))))) (define-values (stx-2list?) (lambda (x) (if (stx-pair? x) @@ -25,20 +56,28 @@ (stx-null? (stx-cdr (stx-cdr x))) #f) #f))) - (if (if (not (stx-list? stx)) - #t - (let-values ([(tail1) (stx-cdr stx)]) - (if (stx-null? tail1) - #t - (if (stx-null? (stx-cdr tail1)) - #t - (if named? - (if (symbol? (syntax-e (stx-car tail1))) - (stx-null? (stx-cdr (stx-cdr tail1))) - #f) - #f))))) - (raise-syntax-error #f "bad syntax" stx) - (void)) + (let-values ([(maybe-msg) + (if (not (stx-list? stx)) + "" + (let-values ([(tail1) (stx-cdr stx)]) + (if (stx-null? tail1) + (if named? + "(missing name or binding pairs)" + "(missing binding pairs)") + (if (stx-null? (stx-cdr tail1)) + (if named? + "(missing binding pairs or body)" + "(missing body)") + (if named? + (if (symbol? (syntax-e (stx-car tail1))) + (if (stx-null? (stx-cdr (stx-cdr tail1))) + "(missing body)" + #f) + #f) + #f)))))]) + (if maybe-msg + (raise-syntax-error #f (string-append "bad syntax " maybe-msg) stx) + (void))) (let-values ([(name) (if named? (let-values ([(n) (stx-cadr stx)]) (if (symbol? (syntax-e n)) @@ -89,39 +128,11 @@ (loop bindings))]) (if star? (void) - (if ((length new-bindings) . > . 5) - (let-values ([(ht) (make-hasheq)]) - (letrec-values ([(check) (lambda (l) - (if (null? l) - (void) - (let*-values ([(id) (if name - (caar l) - (stx-car (stx-car (car l))))] - [(idl) (hash-ref ht (syntax-e id) null)]) - (if (id-in-list? id idl) - (raise-syntax-error - #f - "duplicate identifier" - stx - id) - (begin - (hash-set! ht (syntax-e id) (cons id idl)) - (check (cdr l)))))))]) - (check new-bindings))) - (letrec-values ([(check) (lambda (l accum) - (if (null? l) - (void) - (let-values ([(id) (if name - (caar l) - (stx-car (stx-car (car l))))]) - (if (id-in-list? id accum) - (raise-syntax-error - #f - "duplicate identifier" - stx - id) - (check (cdr l) (cons id accum))))))]) - (check new-bindings null)))) + (check-for-duplicates new-bindings + (if name + car + (lambda (v) (stx-car (stx-car v)))) + stx)) (datum->syntax lambda-stx (if name @@ -141,6 +152,44 @@ body)) stx))))))]) (values + (lambda (stx) + (define-values (bad-syntax) + (lambda () + (raise-syntax-error #f "bad syntax" stx))) + (define-values (l) (syntax->list stx)) + (if (not l) (bad-syntax) (void)) + (if ((length l) . < . 3) (bad-syntax) (void)) + (define-values (bindings) (syntax->list (cadr l))) + (if (not bindings) (raise-syntax-error #f "bad syntax" stx (cadr l)) (void)) + (for-each (lambda (binding) + (define-values (l) (syntax->list binding)) + (if (if (not l) + #t + (not (= 2 (length l)))) + (raise-syntax-error #f "bad syntax" stx binding) + (void)) + (define-values (vars) (syntax->list (car l))) + (if (not vars) (raise-syntax-error #f "bad syntax" stx (car l)) (void)) + (for-each (lambda (var) + (if (not (symbol? (syntax-e var))) + (raise-syntax-error + #f + "bad syntax (not an identifier)" + stx + var) + (void))) + vars) + (check-for-duplicates vars values stx)) + bindings) + (define-values (gen) + (lambda (bindings nested?) + (if (null? bindings) + (if nested? + (cddr l) + (list* (quote-syntax let-values) '() (cddr l))) + ((if nested? list values) + (list* (quote-syntax let-values) (list (car bindings)) (gen (cdr bindings) #t)))))) + (datum->syntax #f (gen bindings #f) stx stx)) (lambda (stx) (go stx #t #f (quote-syntax let-values))) (lambda (stx) (go stx #f #t (quote-syntax let*-values))) (lambda (stx) (go stx #f #f (quote-syntax letrec-values))))))) @@ -149,7 +198,7 @@ (lambda (a b) (if (list? a) (append a b) - (raise-type-error 'unquote-splicing "proper list" a)))) + (raise-argument-error 'unquote-splicing "list?" a)))) (define-syntaxes (quasiquote) (let-values ([(here) (quote-syntax here)] ; id with module bindings, but not lexical @@ -372,7 +421,7 @@ (list (quote-syntax quote) rest) rest))))))))) - (let-values (((l0) (hash-map (syntax-e x) cons))) + (let-values (((l0) (hash-map (syntax-e x) cons #t))) (let-values (((l) (qq-hash-assocs l0 level))) (if (eq? l0 l) @@ -450,5 +499,6 @@ "bad syntax" x)))))))) - (#%provide let let* letrec + (#%provide let*-values + let let* letrec quasiquote and or)) diff --git a/whalesong/parser/parse-bytecode-5.3.3.7.rkt b/whalesong/parser/parse-bytecode-5.3.3.7.rkt index 993ad6b..3a5981a 100644 --- a/whalesong/parser/parse-bytecode-5.3.3.7.rkt +++ b/whalesong/parser/parse-bytecode-5.3.3.7.rkt @@ -6,7 +6,8 @@ (version-case - [(version>= (version) "5.3.3.7") + [(and (version>= (version) "5.3.3.7") + (version< (version) "6.3")) ;; Parsing Racket 5.3 bytecode structures into our own structures. (require "path-rewriter.rkt" diff --git a/whalesong/parser/parse-bytecode-6.3.rkt b/whalesong/parser/parse-bytecode-6.3.rkt new file mode 100644 index 0000000..0ab120c --- /dev/null +++ b/whalesong/parser/parse-bytecode-6.3.rkt @@ -0,0 +1,763 @@ +#lang racket/base + +(require "../version-case/version-case.rkt" + (for-syntax racket/base)) + + + +(version-case + [(version>= (version) "5.3.3.7") + + ;; Parsing Racket 5.3 bytecode structures into our own structures. + (require "path-rewriter.rkt" + "../compiler/expression-structs.rkt" + "../compiler/lexical-structs.rkt" + "../parameters.rkt" + "../get-module-bytecode.rkt" + syntax/modresolve + compiler/zo-parse + racket/path + racket/match + racket/list) + + + (provide parse-bytecode) + + + + ;; current-module-path-index-resolver: (module-path-index (U Path #f) -> (U Symbol Path)) -> void + ;; The module path index resolver figures out how to translate module path indices to module names. + (define current-module-path-index-resolver + (make-parameter + (lambda (mpi relative-to) + (cond + [(eq? mpi #f) + (current-module-path)] + [(self-module-path-index? mpi) + (current-module-path)] + [else + (resolve-module-path-index mpi relative-to)])))) + + + (define current-module-path-resolver + (make-parameter + (lambda (module-path relative-to) + (resolve-module-path module-path relative-to)))) + + + + (define (self-module-path-index? mpi) + (let-values ([(x y) (module-path-index-split mpi)]) + (and (eq? x #f) + (eq? y #f)))) + + + (define (explode-module-path-index mpi) + (let-values ([(x y) (module-path-index-split mpi)]) + (cond + [(module-path-index? y) + (cons x (explode-module-path-index y))] + [else + (list x y)]))) + + + + + ;; seen-closures: (hashof symbol -> symbol) + ;; As we're parsing, we watch for closure cycles. On any subsequent time where + ;; we see a closure cycle, we break the cycle by generating an EmptyClosureReference. + ;; The map is from the gen-id to the entry-point label of the lambda. + (define seen-closures (make-parameter (make-hasheq))) + + + + + + + ;; Code is copied-and-pasted from compiler/decompile. Maps the primval ids to their respective + ;; symbolic names. + (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) + (namespace-require ''#%unsafe) + (namespace-require ''#%flfxnum) + (namespace-require ''#%futures) + (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 ([out (open-output-bytes)]) + (write (cdr b) out) + (close-output-port out) + (open-input-bytes (get-output-bytes out)))))]) + (let ([n (match v + [(struct compilation-top (_ _binding-namess prefix (struct primval (n)))) n] + [else #f])]) + (hash-set! table n (car b))))) + table)) + + + + + + + + + ;; parse-bytecode: (U Input-Port Path) -> Expression + ;; + ;; Given an input port, assumes the input is the byte representation of compiled-code. + ;; + ;; Given a path, assumes the path is for a module. It gets the module bytecode, and parses + ;; that. + ;; + ;; TODO: this may be doing too much work. It doesn't quite feel like the right elements + ;; are being manipulated here. + (define (parse-bytecode in) + (cond + [(input-port? in) + (parameterize ([seen-closures (make-hasheq)]) + (let ([compilation-top (zo-parse in)]) + (parse-top compilation-top)))] + + [(compiled-expression? in) + (let ([op (open-output-bytes)]) + (write in op) + (parse-bytecode (open-input-bytes (get-output-bytes op))))] + + [(path? in) + (let*-values ([(normal-path) (normalize-path in)] + [(base file-path dir?) (split-path normal-path)]) + (parameterize ([current-module-path normal-path] + [current-directory (cond [(path? base) + base] + [else + (error 'parse-bytecode)])]) + (define module-bytecode (get-module-bytecode normal-path)) + (parse-bytecode (open-input-bytes module-bytecode))))] + [else + (error 'parse-bytecode "Don't know how to parse from ~e" in)])) + + + + + + + + (define (parse-top a-top) + (match a-top + [(struct compilation-top (max-let-depth _binding-namess prefix code)) + (maybe-fix-module-name + (make-Top (parse-prefix prefix) + (parse-top-code code)))])) + + + + ;; maybe-fix-module-name: expression -> expression + ;; When we're compiling a module directly from memory, it doesn't have a file path. + ;; We rewrite the ModuleLocator to its given name. + (define (maybe-fix-module-name exp) + (match exp + [(struct Top (top-prefix + (struct Module ((and name (? symbol?)) + (struct ModuleLocator ('self 'self)) + module-prefix + module-requires + module-provides + module-code)))) + (make-Top top-prefix + (make-Module name + (make-ModuleLocator name name) (current-module-path) + module-prefix + module-requires + module-provides + module-code))] + [else + exp])) + + + + (define (parse-prefix a-prefix) + (match a-prefix + [(struct prefix (num-lifts toplevels stxs _src-inspector-desc)) + (make-Prefix + (append (map parse-prefix-toplevel toplevels) + (map (lambda (x) #f) stxs) + (if (empty? stxs) empty (list #f)) + (build-list num-lifts (lambda (i) #f))))])) + + + ;; parse-top-code: (U form Any -> Expression) + (define (parse-top-code code) + (cond + [(form? code) + (parse-form code)] + [else + (make-Constant code)])) + + + ;; parse-prefix-toplevel: (U #f symbol global-bucket module-variable) -> (U False Symbol GlobalBucket ModuleVariable) + (define (parse-prefix-toplevel a-toplevel) + (cond + [(eq? a-toplevel #f) + #f] + [(symbol? a-toplevel) + a-toplevel] + [(global-bucket? a-toplevel) + (make-GlobalBucket (global-bucket-name a-toplevel))] + [(module-variable? a-toplevel) + (let ([resolver (current-module-path-index-resolver)]) + (make-ModuleVariable (module-variable-sym a-toplevel) + (let ([resolved-path-name + (resolver (module-variable-modidx a-toplevel) (current-module-path))]) + (wrap-module-name resolved-path-name))))])) + + (define (wrap-module-name resolved-path-name) + (cond + [(symbol? resolved-path-name) + (make-ModuleLocator resolved-path-name resolved-path-name)] + [(path? resolved-path-name) + (let ([rewritten-path (rewrite-path resolved-path-name)]) + (cond + [(symbol? rewritten-path) + (make-ModuleLocator (rewrite-path resolved-path-name) + (normalize-path resolved-path-name))] + [else + (displayln (list 'wrap-module-name resolved-path-name rewritten-path)) + (error 'wrap-module-name "Unable to resolve module path ~s." + resolved-path-name)]))])) + + + + + + ;; parse-form: form -> (U Expression) + (define (parse-form a-form) + (cond + [(def-values? a-form) + (parse-def-values a-form)] + + [(def-syntaxes? a-form) + (parse-def-syntaxes a-form)] + + [(req? a-form) + (parse-req a-form)] + + [(seq? a-form) + (parse-seq a-form)] + + [(splice? a-form) + (parse-splice a-form)] + + [(mod? a-form) + (parse-mod a-form)] + + [(expr? a-form) + (parse-expr a-form)] + + [else + (error 'parse-form "~s" a-form)])) + + + ;; parse-def-values: def-values -> Expression + (define (parse-def-values form) + (match form + ;; Explicit check for inline-variant first, since that's the only place + ;; it apppears + [(struct def-values (ids (struct inline-variant (direct inline)))) + (make-DefValues (map parse-toplevel ids) + (parse-expr direct))] + + [(struct def-values (ids rhs)) + (make-DefValues (map parse-toplevel ids) + (parse-expr-seq-constant rhs))])) + + + + (define (parse-def-syntaxes form) + ;; Currently, treat def-syntaxes as a no-op. The compiler will not produce + ;; syntax transformers. + (make-Constant (void))) + + + + (define (parse-req form) + (let ([resolver (current-module-path-resolver)]) + (match form + [(struct req (reqs dummy)) + (let ([require-statement (parse-req-reqs reqs)]) + (match require-statement + [(list '#%require (and (? module-path?) path)) + (let ([resolved-path ((current-module-path-resolver) path (current-module-path))]) + (cond + [(symbol? resolved-path) + (make-Require (make-ModuleLocator resolved-path resolved-path))] + [(path? resolved-path) + (let ([rewritten-path (rewrite-path resolved-path)]) + (cond + [(symbol? rewritten-path) + (make-Require (make-ModuleLocator rewritten-path + (normalize-path resolved-path)))] + [else + (printf "Internal error: I don't know how to handle the require for ~s" require-statement) + (error 'parse-req)]))] + [else + (printf "Internal error: I don't know how to handle the require for ~s" require-statement) + (error 'parse-req)]))] + [else + (printf "Internal error: I don't know how to handle the require for ~s" require-statement) + (error 'parse-req)]))]))) + + ;; parse-req-reqs: (stx -> (listof ModuleLocator)) + (define (parse-req-reqs reqs) + (match reqs + [(struct stx (encoded)) + (unwrap-wrapped encoded)])) + + (define (unwrap-wrapped encoded) + (cond #;[(wrapped? encoded) + (match encoded + [(struct wrapped (datum wraps certs)) + (unwrap-wrapped datum)])] + [(pair? encoded) + (cons (unwrap-wrapped (car encoded)) + (unwrap-wrapped (cdr encoded)))] + [(null? encoded) + null] + [else + encoded])) + + + + + ;; parse-seq: seq -> Expression + (define (parse-seq form) + (match form + [(struct seq (forms)) + (make-Seq (map parse-form-item forms))])) + + + ;; parse-form-item: (U form Any) -> Expression + (define (parse-form-item item) + (cond + [(form? item) + (parse-form item)] + [else + (make-Constant item)])) + + + ;; parse-splice: splice -> Expression + (define (parse-splice form) + (match form + [(struct splice (forms)) + (make-Splice (map parse-splice-item forms))])) + + + ;; parse-splice-item: (U form Any) -> Expression + (define (parse-splice-item item) + (cond + [(form? item) + (parse-form item)] + [else + (make-Constant item)])) + + + ;; parse-mod: mod -> Expression + (define (parse-mod form) + (match form + [(struct mod (name srcname self-modidx prefix provides requires + body syntax-body unexported max-let-depth dummy lang-info + internal-context _binding-names flags + pre-submodules post-submodules)) + (cond + [(symbol? name) + ;; FIXME: no support for submodules yet. + (let ([self-path + ((current-module-path-index-resolver) + self-modidx + (current-module-path))]) + (cond + [(symbol? self-path) + (make-Module name + (make-ModuleLocator self-path self-path) + (parse-prefix prefix) + (parse-mod-requires self-modidx requires) + (parse-mod-provides self-modidx provides) + (parse-mod-body body))] + [else + (let ([rewritten-path (rewrite-path self-path)]) + (cond + [(symbol? rewritten-path) + (make-Module name + (make-ModuleLocator rewritten-path + (normalize-path self-path)) + (parse-prefix prefix) + (parse-mod-requires self-modidx requires) + (parse-mod-provides self-modidx provides) + (parse-mod-body body))] + [else + (error 'parse-mod "Internal error: unable to resolve module path ~s" self-path)]))]))] + [else + (error 'parse-bytecode "Whalesong doesn't yet support submodules")])])) + + + + ;; parse-mod-requires: module-path-index (listof (pair (U Integer #f) (listof module-path-index))) -> (listof ModuleLocator) + (define (parse-mod-requires enclosing-module-path-index requires) + ;; We only care about phase 0 --- the runtime. + (let ([resolver (current-module-path-index-resolver)]) + (let loop ([requires requires]) + (cond + [(empty? requires) + empty] + [(= (car (first requires)) + 0) + (map (lambda (m) + (let ([enclosing-path (resolver enclosing-module-path-index (current-module-path))]) + (cond + [(symbol? enclosing-path) + (wrap-module-name (resolver m (current-module-path)))] + [(path? enclosing-path) + (wrap-module-name (resolver m enclosing-path))]))) + (cdr (first requires)))] + [else + (loop (rest requires))])))) + + + + (define (parse-mod-provides enclosing-module-path-index provides) + (let* ([resolver + (current-module-path-index-resolver)] + [enclosing-path + (resolver enclosing-module-path-index (current-module-path))] + [subresolver + (lambda (p) + (cond + [(symbol? enclosing-path) + (wrap-module-name (resolver p (current-module-path)))] + [(path? enclosing-path) + (wrap-module-name (resolver p enclosing-path))]))]) + (let loop ([provides provides]) + (cond + [(empty? provides) + empty] + [(= (first (first provides)) 0) + (let ([provided-values (second (first provides))]) + (for/list ([v provided-values]) + (match v + [(struct provided (name src src-name nom-mod + src-phase protected?)) + (make-ModuleProvide src-name name (subresolver src))])))] + [else + (loop (rest provides))])))) + + + + + + + ;; parse-mod-body: (listof (or/c form? any/c)) -> Expression + (define (parse-mod-body body) + (let ([parse-item (lambda (item) + (cond + [(form? item) + (parse-form item)] + [else + (make-Constant item)]))]) + (make-Splice (map parse-item body)))) + + + + (define (make-lam-label) + (make-label 'lamEntry)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (parse-expr expr) + (cond + [(lam? expr) + (parse-lam expr (make-lam-label))] + [(closure? expr) + (parse-closure expr)] + [(case-lam? expr) + (parse-case-lam expr)] + [(let-one? expr) + (parse-let-one expr)] + [(let-void? expr) + (parse-let-void expr)] + [(install-value? expr) + (parse-install-value expr)] + [(let-rec? expr) + (parse-let-rec expr)] + [(boxenv? expr) + (parse-boxenv expr)] + [(localref? expr) + (parse-localref expr)] + [(toplevel? expr) + (parse-toplevel expr)] + [(topsyntax? expr) + (parse-topsyntax expr)] + [(application? expr) + (parse-application expr)] + [(branch? expr) + (parse-branch expr)] + [(with-cont-mark? expr) + (parse-with-cont-mark expr)] + [(beg0? expr) + (parse-beg0 expr)] + [(varref? expr) + (parse-varref expr)] + [(assign? expr) + (parse-assign expr)] + [(apply-values? expr) + (parse-apply-values expr)] + [(primval? expr) + (parse-primval expr)])) + + (define (parse-lam expr entry-point-label) + (match expr + [(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body)) + (let ([lam-name (extract-lam-name name)]) + (make-Lam lam-name + num-params + rest? + (parse-expr-seq-constant body) + (vector->list closure-map) + entry-point-label))])) + + + ;; parse-closure: closure -> (U Lam EmptyClosureReference) + ;; Either parses as a regular lambda, or if we come across the same closure twice, + ;; breaks the cycle by creating an EmptyClosureReference with the pre-existing lambda + ;; entry point. + (define (parse-closure expr) + (match expr + [(struct closure (code gen-id)) + (let ([seen (seen-closures)]) + (cond + [(hash-has-key? seen gen-id) + (match code + [(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body)) + (let ([lam-name (extract-lam-name name)]) + (make-EmptyClosureReference lam-name + num-params + rest? + (hash-ref seen gen-id)))])] + [else + (let ([fresh-entry-point (make-lam-label)]) + (hash-set! seen gen-id fresh-entry-point) + (parse-lam code fresh-entry-point))]))])) + + + + ;; extract-lam-name: (U Symbol Vector) -> (U Symbol LamPositionalName) + (define (extract-lam-name name) + (cond + [(symbol? name) + name] + [(vector? name) + (match name + [(vector (and (? symbol?) sym) + (and (? path?) source) + (and (? number?) line) + (and (? number?) column) + (and (? number?) offset) + (and (? number?) span) + _) + (let ([try-to-rewrite (rewrite-path source)]) + (make-LamPositionalName sym + (if try-to-rewrite + (symbol->string try-to-rewrite) + (path->string source)) + line + column + offset + span))] + [(vector (and (? symbol?) sym) + (and (? symbol?) source) + (and (? number?) line) + (and (? number?) column) + (and (? number?) offset) + (and (? number?) span) + _) + (make-LamPositionalName sym + (symbol->string source) + line + column + offset + span)] + [else + (string->symbol (format "~s" name))])] + [else + 'unknown + ;; The documentation says that the name must be a symbol or vector, but I'm seeing cases + ;; where it returns the empty list when there's no information available. + ])) + + + + + (define (parse-case-lam exp) + (match exp + [(struct case-lam (name clauses)) + (let ([case-lam-label (make-lam-label)]) + (make-CaseLam (extract-lam-name name) + (map (lambda (l) + (cond + [(closure? l) + (parse-closure l)] + [else + (parse-lam l (make-lam-label))])) + clauses) + case-lam-label))])) + + + (define (parse-let-one expr) + (match expr + [(struct let-one (rhs body flonum? unused?)) + ;; fixme: use flonum? and unused? to generate better code. + (make-Let1 (parse-expr-seq-constant rhs) + (parse-expr-seq-constant body))])) + + + ;; parse-expr-seq-constant: (U expr seq Any) -> Expression + (define (parse-expr-seq-constant x) + (cond + [(expr? x) (parse-expr x)] + [(seq? x) (parse-seq x)] + [else (make-Constant x)])) + + + (define (parse-let-void expr) + (match expr + [(struct let-void (count boxes? body)) + (make-LetVoid count (parse-expr-seq-constant body) boxes?)])) + + + (define (parse-install-value expr) + (match expr + [(struct install-value (count pos boxes? rhs body)) + (make-Seq (list (make-InstallValue count pos (parse-expr-seq-constant rhs) boxes?) + (parse-expr-seq-constant body)))])) + + + (define (parse-let-rec expr) + (match expr + [(struct let-rec (procs body)) + (make-LetRec (map (lambda (p) (parse-lam p (make-lam-label))) + procs) + (parse-expr-seq-constant body))])) + + (define (parse-boxenv expr) + (match expr + [(struct boxenv (pos body)) + (make-BoxEnv pos (parse-expr-seq-constant body))])) + + + (define (parse-localref expr) + (match expr + [(struct localref (unbox? pos clear? other-clears? flonum?)) + ;; FIXME: we should use clear? at the very least: as I understand it, + ;; this is here to maintain safe-for-space behavior. + ;; We should also make use of flonum information to generate better code. + (make-LocalRef pos unbox?)])) + + + (define (parse-toplevel expr) + (match expr + ;; FIXME: we should also keep track of const? and ready? to produce better code, and to + ;; do the required runtime checks when necessary (const?=#f, ready?=#f) + [(struct toplevel (depth pos const? ready?)) + (make-ToplevelRef depth + pos + const? + (if (and (not const?) (not ready?)) + #t + #f))])) + + + (define (parse-topsyntax expr) + ;; We should not get into this because we're only parsing the runtime part of + ;; the bytecode. Treated as a no-op. + (make-Constant (void))) + + + (define (parse-application expr) + (match expr + [(struct application (rator rands)) + (make-App (parse-application-rator rator) + (map parse-application-rand rands))])) + + (define (parse-application-rator rator) + (cond + [(expr? rator) + (parse-expr rator)] + [(seq? rator) + (parse-seq rator)] + [else + (make-Constant rator)])) + + (define (parse-application-rand rand) + (cond + [(expr? rand) + (parse-expr rand)] + [(seq? rand) + (parse-seq rand)] + [else + (make-Constant rand)])) + + + (define (parse-branch expr) + (match expr + [(struct branch (test then else)) + (make-Branch (parse-expr-seq-constant test) + (parse-expr-seq-constant then) + (parse-expr-seq-constant else))])) + + + (define (parse-with-cont-mark expr) + (match expr + [(struct with-cont-mark (key val body)) + (make-WithContMark (parse-expr-seq-constant key) + (parse-expr-seq-constant val) + (parse-expr-seq-constant body))])) + + (define (parse-beg0 expr) + (match expr + [(struct beg0 (seq)) + (make-Begin0 (map parse-expr-seq-constant seq))])) + + + (define (parse-varref expr) + (match expr + [(struct varref (toplevel dummy)) + (make-VariableReference (parse-toplevel toplevel))])) + + (define (parse-assign expr) + (match expr + [(struct assign ((struct toplevel (depth pos const? ready?)) rhs undef-ok?)) + (make-ToplevelSet depth pos (parse-expr-seq-constant rhs))])) + + + (define (parse-apply-values expr) + (match expr + [(struct apply-values (proc args-expr)) + (make-ApplyValues (parse-expr-seq-constant proc) + (parse-expr-seq-constant args-expr))])) + + + (define (parse-primval expr) + (match expr + [(struct primval (id)) + (let ([name (hash-ref primitive-table id)]) + (make-PrimitiveKernelValue name))]))] + + + + [else + (void)]) diff --git a/whalesong/parser/parse-bytecode.rkt b/whalesong/parser/parse-bytecode.rkt index 0765209..3425e86 100644 --- a/whalesong/parser/parse-bytecode.rkt +++ b/whalesong/parser/parse-bytecode.rkt @@ -41,12 +41,19 @@ (require "parse-bytecode-5.3.rkt") (provide (except-out (all-from-out "parse-bytecode-5.3.rkt") parse-bytecode)))] - [(version>= (version) "5.3.3.7") + [(and (version>= (version) "5.3.3.7") + (version< (version) "6.3")) (begin (log-debug "Using 5.3.3.7 bytecode parser") (require "parse-bytecode-5.3.3.7.rkt") (provide (except-out (all-from-out "parse-bytecode-5.3.3.7.rkt") parse-bytecode)))] + [(version>= (version) "6.3") + (begin + (log-debug "Using 6.3 bytecode parser") + (require "parse-bytecode-6.3.rkt") + (provide (except-out (all-from-out "parse-bytecode-6.3.rkt") + parse-bytecode)))] [else (error 'parse-bytecode "Whalesong doesn't have a compatible parser for Racket ~a" (version))])