suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

expander as pkg: repair source mode

Browse Source 
When support for machine-independent bytecode was added, the bootstrap
implementation of linklets ended up being slightly uncooperative.
Source terms from the bootstrap became wrapped as machine-independent
form. For various reasons, things worked anyway, except that
`--linklets` mode prints bytecode instead of S-expressions. Fix the
bootstrap implementation to cooperate correctly.

Related to #2688
This commit is contained in:
Matthew Flatt 2019-06-09 08:52:02 -06:00
parent c020bd4feb
commit d136245e3b
6 changed files with 137 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
racket/src/expander/boot/linklet-primitive.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require "../host/linklet.rkt"
"../compile/linklet.rkt"
"../compile/linklet-api.rkt"
"../common/reflect-hash.rkt"
"../run/linklet-operation.rkt")

20
racket/src/expander/compile/linklet-api.rkt Normal file
View File

@ -0,0 +1,20 @@
#lang racket/base
(require (rename-in "linklet.rkt"
[linklet-directory? raw:linklet-directory?]
[linklet-directory->hash raw:linklet-directory->hash])
"compiled-in-memory.rkt")
(provide linklet-directory?
linklet-directory->hash
(except-out (all-from-out "linklet.rkt")
raw:linklet-directory?
raw:linklet-directory->hash))
(define (linklet-directory? v)
(or (raw:linklet-directory? v)
(compiled-in-memory? v)))
(define (linklet-directory->hash ld)
(raw:linklet-directory->hash (if (compiled-in-memory? ld)
(compiled-in-memory-linklet-directory ld)
ld)))

1
racket/src/expander/compile/module.rkt
View File

@ -36,7 +36,6 @@
#:to-correlated-linklet? [to-correlated-linklet? #f]
#:modules-being-compiled [modules-being-compiled (make-hasheq)]
#:need-compiled-submodule-rename? [need-compiled-submodule-rename? #t])
(define full-module-name (let ([parent-full-name (compile-context-full-module-name cctx)]
[name (syntax-e (parsed-module-name-id p))])
(if parent-full-name

23
racket/src/expander/run.rkt
View File

@ -13,12 +13,16 @@
"namespace/namespace.rkt"
"common/module-path.rkt"
"eval/module-read.rkt"
"compile/linklet-api.rkt"
"boot/kernel.rkt"
"run/cache.rkt"
"boot/runtime-primitive.rkt"
"host/linklet.rkt"
"run/status.rkt"
"run/submodule.rkt"
(only-in "run/linklet.rkt"
linklet-as-s-expr?
linklet-as-s-expr)
"host/correlate.rkt"
"extract/main.rkt"
(only-in "run/linklet.rkt" linklet-compile-to-s-expr))
@ -299,7 +303,9 @@
(define (apply-to-module proc mod-path)
(define path (resolved-module-path-name
(resolve-module-path mod-path #f)))
(module-path-index-resolve
(module-path-index-join mod-path #f)
#f)))
(define-values (dir file dir?) (split-path path))
(parameterize ([current-load-relative-directory dir])
(proc (call-with-input-file*
@ -312,13 +318,26 @@
(read-syntax (object-name i) i)
path))))))))
(define (extract-linklets l)
(cond
[(linklet-bundle? l)
(for/hasheq ([(k v) (in-hash (linklet-bundle->hash l))])
(values k (extract-linklets v)))]
[(linklet-directory? l)
(for/hasheq ([(k v) (in-hash (linklet-directory->hash l))])
(values k (extract-linklets v)))]
[(linklet-as-s-expr? l) (linklet-as-s-expr l)]
[else l]))
(cond
[expand?
(pretty-write (syntax->datum (apply-to-module expand startup-module)))]
[linklets?
(pretty-write (correlated->datum
(datum->correlated
(apply-to-module compile startup-module) #f)))]
(extract-linklets
(apply-to-module compile startup-module))
#f)))]
[else
;; Load and run the requested module
(parameterize ([current-command-line-arguments (list->vector args)])

70
racket/src/expander/run/linklet.rkt
View File

@ -42,15 +42,20 @@
;; Helpers for "extract.rkt"
(provide linklet-compile-to-s-expr ; a parameter; whether to "compile" to a source form
linklet-as-s-expr?
linklet-as-s-expr
s-expr-linklet-importss+localss
s-expr-linklet-exports+locals
s-expr-linklet-body)
(struct linklet (compiled-proc ; takes self instance plus instance arguments to run the linklet body
importss ; list [length is 1 less than proc arity] of list of symbols
exports) ; list of symbols
#:prefab)
(struct linklet () #:prefab)
(struct source-linklet linklet (src) #:prefab)
(struct compiled-linklet linklet (compiled-proc ; takes self instance plus instance arguments to run the linklet body
importss ; list [length is 1 less than proc arity] of list of symbols
exports) ; list of symbols
#:prefab)
(struct instance (name ; for debugging, typically a module name + phase
data ; any value (e.g., a namespace)
@ -312,7 +317,7 @@
(define l
(cond
[(linklet-compile-to-s-expr)
(marshal (correlated->datum/lambda-name c))]
(source-linklet (marshal (correlated->datum/lambda-name c)))]
[else
(define plain-c (desugar-linklet c))
(parameterize ([current-namespace cu-namespace]
@ -320,9 +325,9 @@
[current-compile orig-compile])
;; Use a vector to list the exported variables
;; with the compiled bytecode
(linklet (compile plain-c)
(marshal (extract-import-variables-from-expression c #:pairs? #f))
(marshal (extract-export-variables-from-expression c #:pairs? #f))))]))
(compiled-linklet (compile plain-c)
(marshal (extract-import-variables-from-expression c #:pairs? #f))
(marshal (extract-export-variables-from-expression c #:pairs? #f))))]))
(if import-keys
(values l import-keys) ; no imports added or removed
l))
@ -339,7 +344,7 @@
c)
(define (linklet-virtual-machine-bytes)
#"source")
#"exp")
(define (write-linklet-bundle-hash ld in)
(write ld in))
@ -352,19 +357,25 @@
(parameterize ([current-namespace cu-namespace]
[current-eval orig-eval]
[current-compile orig-compile])
(if (linklet? cl)
;; Normal mode: compiled to struct
(eval (linklet-compiled-proc cl))
;; Assume previously "compiled" to source:
(or (hash-ref eval-cache cl #f)
(let ([proc (eval (desugar-linklet (unmarshal cl)))])
(hash-set! eval-cache cl proc)
proc)))))
(cond
[(compiled-linklet? cl)
;; Normal mode: compiled to struct
(eval (compiled-linklet-compiled-proc cl))]
[(source-linklet? cl)
;; Previously "compiled" to source:
(or (hash-ref eval-cache cl #f)
(let ([proc (eval (desugar-linklet (unmarshal (source-linklet-src cl))))])
(hash-set! eval-cache cl proc)
proc))]
[else (error 'eval-linklet "unrecognized: ~s" cl)])))
(define eval-cache (make-weak-hasheq))
;; Check whether we previously compiled a linket to source
(define (linklet-as-s-expr? cl)
(not (linklet? cl)))
(source-linklet? cl))
(define (linklet-as-s-expr cl)
(source-linklet-src cl))
;; Instantiate
(define (instantiate-linklet linklet import-instances [target-instance #f] [use-prompt? #t])
@ -381,27 +392,32 @@
;; ----------------------------------------
(define (linklet-import-variables linklet)
(if (linklet? linklet)
(if (compiled-linklet? linklet)
;; Compiled to a prefab that includes metadata
(linklet-importss linklet)
(compiled-linklet-importss linklet)
;; Previously "compiled" to source
(extract-import-variables-from-expression linklet #:pairs? #f)))
(extract-import-variables-from-expression (source-linklet-src linklet) #:pairs? #f)))
(define (linklet-export-variables linklet)
(if (linklet? linklet)
(if (compiled-linklet? linklet)
;; Compiled to a prefab that includes metadata
(linklet-exports linklet)
(compiled-linklet-exports linklet)
;; Previously "compiled" to source
(extract-export-variables-from-expression linklet #:pairs? #f)))
(extract-export-variables-from-expression (source-linklet-src linklet) #:pairs? #f)))
(define (s-expr-linklet-importss+localss linklet)
(extract-import-variables-from-expression linklet #:pairs? #t))
(extract-import-variables-from-expression (->s-expr linklet) #:pairs? #t))
(define (s-expr-linklet-exports+locals linklet)
(extract-export-variables-from-expression linklet #:pairs? #t))
(extract-export-variables-from-expression (->s-expr linklet) #:pairs? #t))
(define (s-expr-linklet-body linklet)
(unmarshal (list-tail linklet 3)))
(unmarshal (list-tail (->s-expr linklet) 3)))
(define (->s-expr l)
(if (linklet-as-s-expr? l)
(linklet-as-s-expr l)
l))
;; ----------------------------------------

89
racket/src/racket/src/startup.inc
View File

@ -18569,7 +18569,10 @@ static const char *startup_source =
" fasl-single-flonum-type"
" o_1)"
"(1/write-bytes"
"(if(eqv? v_1 +nan.f)"
"(if(eqv?"
" v_1"
"(real->single-flonum"
" +nan.0))"
" #\"\\0\\0\\300\\177\""
"(real->floating-point-bytes"
" v_1"
@ -29460,7 +29463,7 @@ static const char *startup_source =
" len_0))))"
"(define-values(write-int)(lambda(n_0 port_0)(begin(write-bytes(integer->integer-bytes n_0 4 #f #f) port_0))))"
"(define-values"
"(struct:linklet-directory linklet-directory1.1 linklet-directory? linklet-directory-ht)"
"(struct:linklet-directory linklet-directory1.1 linklet-directory?$1 linklet-directory-ht)"
"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)"
"(let-values()"
"(let-values()"
@ -29477,7 +29480,7 @@ static const char *startup_source =
"(write-linklet-directory"
" ld_0"
"(correlated-linklet-directory? ld_0)"
" linklet-directory->hash"
" linklet-directory->hash$1"
" linklet-bundle->hash"
" port_0))))"
"(current-inspector)"
@ -29553,7 +29556,7 @@ static const char *startup_source =
" v_0))))"
"(if(symbol? k_0)"
"(let-values()"
"(if(linklet-directory? v_0)"
"(if(linklet-directory?$1 v_0)"
"(void)"
"(let-values()"
"(raise-arguments-error"
@ -29629,13 +29632,14 @@ static const char *startup_source =
"(void)"
"(linklet-bundle2.1 ht_0)))))))"
"(define-values"
"(linklet-directory->hash)"
"(linklet-directory->hash$1)"
"(lambda(ld_0)"
"(begin"
" 'linklet-directory->hash"
"(let-values()"
"(let-values()"
"(begin"
"(if(linklet-directory? ld_0)"
"(if(linklet-directory?$1 ld_0)"
"(void)"
" (let-values () (raise-argument-error 'linklet-directory->hash \"linklet-directory?\" ld_0)))"
"(linklet-directory-ht ld_0)))))))"
@ -29654,7 +29658,7 @@ static const char *startup_source =
"(correlated-linklet-directory?)"
"(lambda(ld_0)"
"(begin"
"(let-values(((ht_0)(linklet-directory->hash ld_0)))"
"(let-values(((ht_0)(linklet-directory->hash$1 ld_0)))"
"(begin"
"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_0)))"
"((letrec-values(((for-loop_0)"
@ -33694,7 +33698,7 @@ static const char *startup_source =
"(compiled-top->compiled-tops)"
"(lambda(ld_0)"
"(begin"
"(let-values(((ht_0)(linklet-directory->hash ld_0)))"
"(let-values(((ht_0)(linklet-directory->hash$1 ld_0)))"
"(reverse$1"
"(let-values(((start_0) 0)((end_0)(hash-count ht_0))((inc_0) 1))"
"(begin"
@ -38239,8 +38243,8 @@ static const char *startup_source =
"(begin"
"(let-values(((ld/h_0)(if(compiled-in-memory? c_0)(compiled-in-memory-linklet-directory c_0) c_0)))"
"(let-values(((dh_0)"
"(if(linklet-directory? ld/h_0)"
"(let-values()(linklet-directory->hash ld/h_0))"
"(if(linklet-directory?$1 ld/h_0)"
"(let-values()(linklet-directory->hash$1 ld/h_0))"
"(let-values() #f))))"
"(let-values(((h_0)(linklet-bundle->hash(if dh_0(hash-ref dh_0 #f) ld/h_0))))(values dh_0 h_0)))))))"
"(define-values(compiled-module->h)(lambda(c_0)(begin(let-values(((dh_0 h_0)(compiled-module->dh+h c_0))) h_0))))"
@ -38678,7 +38682,7 @@ static const char *startup_source =
"(let-values(((or-part_0)(compiled-in-memory? c_0)))"
"(if or-part_0"
" or-part_0"
"(let-values(((or-part_1)(linklet-directory? c_0)))(if or-part_1 or-part_1(linklet-bundle? c_0))))))))"
"(let-values(((or-part_1)(linklet-directory?$1 c_0)))(if or-part_1 or-part_1(linklet-bundle? c_0))))))))"
"(define-values"
"(1/compiled-module-expression?)"
"(lambda(c_0)"
@ -38686,8 +38690,8 @@ static const char *startup_source =
" 'compiled-module-expression?"
"(let-values(((ld_0)(compiled->linklet-directory-or-bundle c_0)))"
"(let-values(((or-part_0)"
"(if(linklet-directory? ld_0)"
"(if(let-values(((b_0)(hash-ref(linklet-directory->hash ld_0) #f #f)))"
"(if(linklet-directory?$1 ld_0)"
"(if(let-values(((b_0)(hash-ref(linklet-directory->hash$1 ld_0) #f #f)))"
"(if b_0(hash-ref(linklet-bundle->hash b_0) 'decl #f) #f))"
" #t"
" #f)"
@ -38702,7 +38706,7 @@ static const char *startup_source =
"(normalize-to-linklet-directory)"
"(lambda(c_0)"
"(begin"
"(if(linklet-directory?(compiled->linklet-directory-or-bundle c_0))"
"(if(linklet-directory?$1(compiled->linklet-directory-or-bundle c_0))"
"(let-values() c_0)"
"(if(linklet-bundle? c_0)"
"(let-values()(hash->linklet-directory(hasheq #f c_0)))"
@ -38770,7 +38774,7 @@ static const char *startup_source =
"(lambda(c_0)"
"(begin"
"(let-values(((ld_0)(compiled->linklet-directory-or-bundle c_0)))"
"(let-values(((b_0)(if(linklet-bundle? ld_0) ld_0(hash-ref(linklet-directory->hash ld_0) #f))))"
"(let-values(((b_0)(if(linklet-bundle? ld_0) ld_0(hash-ref(linklet-directory->hash$1 ld_0) #f))))"
"(hash-ref(linklet-bundle->hash b_0) 'name))))))"
"(define-values"
"(module-compiled-immediate-name)"
@ -38811,7 +38815,7 @@ static const char *startup_source =
"(compiled->linklet-directory-or-bundle c_0)))"
"(if(linklet-bundle? ld_0)"
" ld_0"
"(hash-ref(linklet-directory->hash ld_0) #f)))"
"(hash-ref(linklet-directory->hash$1 ld_0) #f)))"
" full-name_0))"
"((temp13_0)(symbol? full-name_0))"
"((temp14_0)"
@ -38832,10 +38836,10 @@ static const char *startup_source =
"(compiled-in-memory-namespace-scopes the-struct_0)"
"(compiled-in-memory-purely-functional? the-struct_0)))"
" (raise-argument-error 'struct-copy \"compiled-in-memory?\" the-struct_0)))))))"
"(if(linklet-directory? c_0)"
"(if(linklet-directory?$1 c_0)"
"(let-values()"
"(hash->linklet-directory"
"(let-values(((ht_0)(linklet-directory->hash c_0)))"
"(let-values(((ht_0)(linklet-directory->hash$1 c_0)))"
"(begin"
"(if(variable-reference-from-unsafe?(#%variable-reference))"
"(void)"
@ -38946,9 +38950,9 @@ static const char *startup_source =
"(compiled-in-memory-pre-compiled-in-memorys c_0)"
"(compiled-in-memory-post-compiled-in-memorys c_0)))"
"(let-values()"
"(if(linklet-directory? c_0)"
"(if(linklet-directory?$1 c_0)"
"(let-values()"
"(let-values(((ht_0)(linklet-directory->hash c_0)))"
"(let-values(((ht_0)(linklet-directory->hash$1 c_0)))"
"(let-values(((bh_0)(linklet-bundle->hash(hash-ref ht_0 #f))))"
"(let-values(((names_0)(hash-ref bh_0(if non-star?_0 'pre 'post) null)))"
"(reverse$1"
@ -39016,7 +39020,7 @@ static const char *startup_source =
"(let-values(((temp5_0)"
"(reset-submodule-names"
"(hash-ref"
"(linklet-directory->hash"
"(linklet-directory->hash$1"
"(compiled->linklet-directory-or-bundle n-c_0))"
" #f)"
" non-star?_0"
@ -39045,7 +39049,9 @@ static const char *startup_source =
"(fixup-submodule-names"
"(let-values(((temp8_0)"
"(reset-submodule-names"
"(hash-ref(linklet-directory->hash(compiled->linklet-directory-or-bundle n-c_0)) #f)"
"(hash-ref"
"(linklet-directory->hash$1(compiled->linklet-directory-or-bundle n-c_0))"
" #f)"
" non-star?_0"
" submods_0))"
"((temp9_0)"
@ -40155,10 +40161,10 @@ static const char *startup_source =
" sm-self_0)"
"(let-values(((ht_0)"
"(linklet-bundle->hash"
"(if(linklet-directory?"
"(if(linklet-directory?$1"
" ld_0)"
"(hash-ref"
"(linklet-directory->hash"
"(linklet-directory->hash$1"
" ld_0)"
" #f)"
" ld_0))))"
@ -40261,7 +40267,7 @@ static const char *startup_source =
"(let-values(((target-machine_0)(current-compile-target-machine)))"
"(if(not target-machine_0)"
"(let-values() c_0)"
"(if(let-values(((or-part_0)(linklet-bundle? c_0)))(if or-part_0 or-part_0(linklet-directory? c_0)))"
"(if(let-values(((or-part_0)(linklet-bundle? c_0)))(if or-part_0 or-part_0(linklet-directory?$1 c_0)))"
"(let-values()"
"(let-values(((ns_0)(1/current-namespace)))"
"(let-values(((bundles_0)(extract-linklet-bundles c_0 '() '#hash())))"
@ -40334,9 +40340,9 @@ static const char *startup_source =
"(begin"
"(if(linklet-bundle? c_0)"
"(let-values()(hash-set accum_0(reverse$1 rev-path_0) c_0))"
"(if(linklet-directory? c_0)"
"(if(linklet-directory?$1 c_0)"
"(let-values()"
"(let-values(((ht_0)(linklet-directory->hash c_0)))"
"(let-values(((ht_0)(linklet-directory->hash$1 c_0)))"
"(begin"
"(if(variable-reference-from-unsafe?(#%variable-reference))"
"(void)"
@ -40377,10 +40383,10 @@ static const char *startup_source =
"(begin"
"(if(linklet-bundle? c_0)"
"(let-values()(recompiled-bundle(hash-ref recompileds_0(reverse$1 rev-path_0))))"
"(if(linklet-directory? c_0)"
"(if(linklet-directory?$1 c_0)"
"(let-values()"
"(hash->linklet-directory"
"(let-values(((ht_0)(linklet-directory->hash c_0)))"
"(let-values(((ht_0)(linklet-directory->hash$1 c_0)))"
"(begin"
"(if(variable-reference-from-unsafe?(#%variable-reference))"
"(void)"
@ -40843,7 +40849,7 @@ static const char *startup_source =
" or-part_0"
"(let-values(((b_0)"
"(hash-ref"
"(linklet-directory->hash ld_0)"
"(linklet-directory->hash$1 ld_0)"
" #f"
" #f)))"
"(if b_0"
@ -41141,7 +41147,7 @@ static const char *startup_source =
"(if(linklet-bundle? ld_0)"
"(let-values() null)"
"(let-values()"
"(let-values(((h_0)(linklet-directory->hash ld_0)))"
"(let-values(((h_0)(linklet-directory->hash$1 ld_0)))"
"(let-values(((mod_0)(hash-ref h_0 #f #f)))"
" (let-values ((() (begin (if mod_0 (void) (let-values () (error \"missing main module\"))) (values))))"
"(let-values(((mh_0)(linklet-bundle->hash mod_0)))"
@ -41188,7 +41194,7 @@ static const char *startup_source =
"(lambda(c_0)"
"(begin"
"(let-values(((ld_0)(if(compiled-in-memory? c_0)(compiled-in-memory-linklet-directory c_0) c_0)))"
"(if(linklet-directory? ld_0)(not(hash-ref(linklet-directory->hash ld_0) #f #f)) #f)))))"
"(if(linklet-directory?$1 ld_0)(not(hash-ref(linklet-directory->hash$1 ld_0) #f #f)) #f)))))"
"(define-values"
"(eval-top)"
"(let-values(((eval-top5_0)"
@ -41233,13 +41239,13 @@ static const char *startup_source =
" l_0)))))"
"(if(compiled-in-memory? c_0)"
"(let-values()(eval-compiled-parts_0(compiled-in-memory-pre-compiled-in-memorys c_0)))"
"(let-values(((c1_0)(hash-ref(linklet-directory->hash c_0) 'data #f)))"
"(let-values(((c1_0)(hash-ref(linklet-directory->hash$1 c_0) 'data #f)))"
"(if c1_0"
"((lambda(data-ld_0)"
"(eval-compiled-parts_0"
"(create-compiled-in-memorys-using-shared-data"
"(compiled-top->compiled-tops c_0)"
"(hash-ref(linklet-bundle->hash(hash-ref(linklet-directory->hash data-ld_0) #f)) 0)"
"(hash-ref(linklet-bundle->hash(hash-ref(linklet-directory->hash$1 data-ld_0) #f)) 0)"
" ns_0)))"
" c1_0)"
"(let-values()(eval-compiled-parts_0(compiled-top->compiled-tops c_0))))))))))"
@ -41261,7 +41267,7 @@ static const char *startup_source =
"(let-values()"
"(let-values(((ld_0)"
"(if(compiled-in-memory? c_0)(compiled-in-memory-linklet-directory c_0) c_0)))"
"(let-values(((h_0)(linklet-bundle->hash(hash-ref(linklet-directory->hash ld_0) #f))))"
"(let-values(((h_0)(linklet-bundle->hash(hash-ref(linklet-directory->hash$1 ld_0) #f))))"
"(let-values(((link-instance_0)"
"(if(compiled-in-memory? c_0)"
"(link-instance-from-compiled-in-memory"
@ -48852,14 +48858,14 @@ static const char *startup_source =
"(if(let-values(((or-part_0)(compiled-in-memory? s_0)))"
"(if or-part_0"
" or-part_0"
"(let-values(((or-part_1)(linklet-directory? s_0)))"
"(let-values(((or-part_1)(linklet-directory?$1 s_0)))"
"(if or-part_1 or-part_1(linklet-bundle? s_0)))))"
"(let-values()(eval-compiled s_0 ns_0))"
"(if(if(syntax?$1 s_0)"
"(let-values(((or-part_0)(compiled-in-memory?(1/syntax-e s_0))))"
"(if or-part_0"
" or-part_0"
"(let-values(((or-part_1)(linklet-directory?(1/syntax-e s_0))))"
"(let-values(((or-part_1)(linklet-directory?$1(1/syntax-e s_0))))"
"(if or-part_1 or-part_1(linklet-bundle?(1/syntax-e s_0))))))"
" #f)"
"(let-values()(eval-compiled(1/syntax->datum s_0) ns_0))"
@ -64328,6 +64334,15 @@ static const char *startup_source =
" 'TH-place-channel-out"
" TH-place-channel-out))"
"(define-values"
"(linklet-directory?)"
"(lambda(v_0)"
"(begin(let-values(((or-part_0)(linklet-directory?$1 v_0)))(if or-part_0 or-part_0(compiled-in-memory? v_0))))))"
"(define-values"
"(linklet-directory->hash)"
"(lambda(ld_0)"
"(begin"
"(linklet-directory->hash$1(if(compiled-in-memory? ld_0)(compiled-in-memory-linklet-directory ld_0) ld_0)))))"
"(define-values"
"(linklet-primitives)"
"(hasheq"
" 'primitive-table"