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

first cut at submodules

Browse Source 
original commit: 3d69dfab86
This commit is contained in:
Matthew Flatt 2012-03-05 14:47:12 -07:00
parent 02d466aec0
commit a0837b2453
10 changed files with 312 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/compiler/decompile.rkt
View File

@ -1,8 +1,9 @@
#lang scheme/base
#lang racket/base
(require compiler/zo-parse
syntax/modcollapse
scheme/port
scheme/match
racket/port
racket/match
racket/list
racket/set)
(provide decompile)
@ -162,15 +163,17 @@
[(symbol? modidx) modidx]
[else (collapse-module-path-index modidx (current-directory))]))
(define (decompile-module mod-form stack stx-ht)
(define (decompile-module mod-form orig-stack stx-ht name)
(match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported
max-let-depth dummy lang-info internal-context))
max-let-depth dummy lang-info internal-context pre-submodules post-submodules))
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]
[(stack) (append '(#%modvars) stack)]
[(stack) (append '(#%modvars) orig-stack)]
[(closed) (make-hasheq)])
`(module ,name ....
`(,name ,(if (symbol? name) name (last name)) .... ,internal-context
,@defns
,@(for/list ([submod (in-list pre-submodules)])
(decompile-module submod orig-stack stx-ht 'module))
,@(for/list ([b (in-list syntax-bodies)])
(let loop ([n (sub1 (car b))])
(if (zero? n)
@ -180,13 +183,15 @@
(list 'begin-for-syntax (loop (sub1 n))))))
,@(map (lambda (form)
(decompile-form form globs stack closed stx-ht))
body)))]
body)
,@(for/list ([submod (in-list post-submodules)])
(decompile-module submod orig-stack stx-ht 'module*))))]
[else (error 'decompile-module "huh?: ~e" mod-form)]))
(define (decompile-form form globs stack closed stx-ht)
(match form
[(? mod?)
(decompile-module form stack stx-ht)]
(decompile-module form stack stx-ht 'module)]
[(struct def-values (ids rhs))
`(define-values ,(map (lambda (tl)
(match tl

3
collects/compiler/demodularizer/merge.rkt
View File

@ -109,7 +109,8 @@
(define (merge-module max-let-depth top-prefix mod-form)
(match mod-form
[(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies
unexported mod-max-let-depth dummy lang-info internal-context))
unexported mod-max-let-depth dummy lang-info internal-context
pre-submodules post-submodules))
(define toplevel-offset (length (prefix-toplevels top-prefix)))
(define topsyntax-offset (length (prefix-stxs top-prefix)))
(define lift-offset (prefix-num-lifts top-prefix))

3
collects/compiler/demodularizer/nodep.rkt
View File

@ -113,7 +113,8 @@
(define (nodep-module mod-form phase)
(match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies
unexported max-let-depth dummy lang-info internal-context))
unexported max-let-depth dummy lang-info internal-context
pre-submodules post-submodules))
(define new-prefix prefix)
; Cache all the mpi paths
(for-each (match-lambda

131
collects/compiler/zo-marshal.rkt
View File

@ -25,6 +25,119 @@
(get-output-bytes bs))
(define (zo-marshal-to top outp)
(if (and (mod? (compilation-top-code top))
(or (pair? (mod-pre-submodules (compilation-top-code top)))
(pair? (mod-post-submodules (compilation-top-code top)))))
;; module directory and submodules:
(zo-marshal-modules-to top outp)
;; single module or other:
(zo-marshal-top-to top outp)))
(define (zo-marshal-modules-to top outp)
;; Write the compiled form header
(write-bytes #"#~" outp)
;; Write the version:
(define version-bs (string->bytes/latin-1 (version)))
(write-bytes (bytes (bytes-length version-bs)) outp)
(write-bytes version-bs outp)
(write-byte (char->integer #\D) outp)
(struct mod-bytes (code-bstr name-bstr offset))
;; bytestring encodings of the modules and module names
;; --- in the order that they must be written:
(define pre-mod-bytess
(reverse
(let loop ([m (compilation-top-code top)] [pre-accum null])
(define (encode-module-name name)
(if (symbol? name)
#""
(apply bytes-append
(for/list ([sym (in-list (cdr name))])
(define b (string->bytes/utf-8 (symbol->string sym)))
(define len (bytes-length b))
(bytes-append (if (len . < . 255)
(bytes len)
(bytes-append
(bytes 255)
(integer->integer-bytes len 4 #f #f)))
b)))))
(define accum
(let iloop ([accum pre-accum] [subm (mod-pre-submodules m)])
(if (null? subm)
accum
(iloop (loop (car subm) accum) (cdr subm)))))
(define o (open-output-bytes))
(zo-marshal-top-to (struct-copy compilation-top top
[code (struct-copy mod m
[pre-submodules null]
[post-submodules null])])
o)
(define new-accum
(cons (mod-bytes (get-output-bytes o)
(encode-module-name (mod-name m))
0)
accum))
(let iloop ([accum new-accum] [subm (mod-post-submodules m)])
(if (null? subm)
accum
(iloop (loop (car subm) accum) (cdr subm)))))))
(write-bytes (int->bytes (length pre-mod-bytess)) outp)
;; Size of btree:
(define btree-size
(+ 8
(string-length (version))
(apply + (for/list ([mb (in-list pre-mod-bytess)])
(+ (bytes-length (mod-bytes-name-bstr mb))
20)))))
;; Add offsets to mod-bytess:
(define mod-bytess (let loop ([offset btree-size] [mod-bytess pre-mod-bytess])
(if (null? mod-bytess)
null
(let ([mb (car mod-bytess)])
(cons (mod-bytes (mod-bytes-code-bstr mb)
(mod-bytes-name-bstr mb)
offset)
(loop (+ offset
(bytes-length (mod-bytes-code-bstr mb)))
(cdr mod-bytess)))))))
;; Sort by name for btree order:
(define sorted-mod-bytess
(list->vector (sort mod-bytess bytes<? #:key mod-bytes-name-bstr)))
(define right-offsets (make-vector (vector-length sorted-mod-bytess) 0))
;; Write out btree or compute offsets:
(define (write-btree write-bytes)
(let loop ([lo 0] [hi (vector-length sorted-mod-bytess)] [pos 0])
(define mid (quotient (+ lo hi) 2))
(define mb (vector-ref sorted-mod-bytess mid))
(define name-len (bytes-length (mod-bytes-name-bstr mb)))
(write-bytes (int->bytes name-len) outp)
(write-bytes (mod-bytes-name-bstr mb) outp)
(write-bytes (int->bytes (mod-bytes-offset mb)) outp)
(write-bytes (int->bytes (bytes-length (mod-bytes-code-bstr mb))) outp)
(define left-pos (+ pos name-len 20))
(write-bytes (int->bytes (if (= lo mid)
0
left-pos))
outp)
(write-bytes (int->bytes (if (= (add1 mid) hi)
0
(vector-ref right-offsets mid)))
outp)
(define right-pos (if (= lo mid)
left-pos
(loop lo mid left-pos)))
(vector-set! right-offsets mid right-pos)
(if (= (add1 mid) hi)
right-pos
(loop (add1 mid) hi right-pos))))
(write-btree void) ; to fill `right-offsets'
(write-btree write-bytes) ; to actually write the btree
;; write modules:
(for ([mb (in-list mod-bytess)])
(write-bytes (mod-bytes-code-bstr mb) outp)))
(define (zo-marshal-top-to top outp)
; XXX: wraps were encoded in traverse, now needs to be handled when writing
(define wrapped (make-hash))
@ -127,6 +240,8 @@
(write-bytes (bytes (bytes-length version-bs)) outp)
(write-bytes version-bs outp)
(write-byte (char->integer #\T) outp)
; Write empty hash code
(write-bytes (make-bytes 20 0) outp)
@ -821,9 +936,14 @@
[else (error 'out-anything "~s" (current-type-trace))])))))
(define (out-module mod-form out)
(out-marshaled module-type-num
(convert-module mod-form)
out))
(define (convert-module mod-form)
(match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported
max-let-depth dummy lang-info internal-context))
max-let-depth dummy lang-info internal-context pre-submodules post-submodules))
(let* ([lookup-req (lambda (phase)
(let ([a (assq phase requires)])
(if a
@ -917,12 +1037,13 @@
[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 (map convert-module post-submodules) l)]
[l (cons (map convert-module pre-submodules) l)]
[l (cons self-modidx l)]
[l (cons srcname l)]
[l (cons name l)])
(out-marshaled module-type-num
l
out))]))
[l (cons (if (pair? name) (car name) name) l)]
[l (cons (if (pair? name) (cdr name) null) l)])
l)]))
(define (lookup-encoded-wrapped w out)
(hash-ref! (out-encoded-wraps out) w

119
collects/compiler/zo-parse.rkt
View File

@ -247,17 +247,25 @@
(define (read-module v)
(match v
[`(,name ,srcname ,self-modidx ,lang-info ,functional? ,et-functional?
,rename ,max-let-depth ,dummy
,prefix ,num-phases
,provide-phase-count . ,rest)
[`(,submod-path
,name ,srcname ,self-modidx
,pre-submods ,post-submods
,lang-info ,functional? ,et-functional?
,rename ,max-let-depth ,dummy
,prefix ,num-phases
,provide-phase-count . ,rest)
(let*-values ([(phase-data rest-module) (split-phase-data rest provide-phase-count)]
[(bodies rest-module) (values (take rest-module num-phases)
(drop rest-module num-phases))])
(match rest-module
[`(,requires ,syntax-requires ,template-requires ,label-requires
,more-requires-count . ,more-requires)
(make-mod name srcname self-modidx
(make-mod (if (null? submod-path)
name
(if (symbol? name)
(cons name submod-path)
(cons (car name) submod-path)))
srcname self-modidx
prefix
;; provides:
(for/list ([l (in-list phase-data)])
@ -325,7 +333,9 @@
max-let-depth
dummy
lang-info
rename)]))]))
rename
(map read-module pre-submods)
(map read-module post-submods))]))]))
(define (read-module-wrap v)
v)
@ -1029,15 +1039,101 @@
(set-cport-pos! cp save-pos)))
(placeholder-get ph))))
;; path -> bytes
;; implementes read.c:read_compiled
(define (zo-parse [port (current-input-port)])
(define (read-prefix port)
;; skip the "#~"
(unless (equal? #"#~" (read-bytes 2 port))
(error 'zo-parse "not a bytecode stream"))
(define version (read-bytes (min 63 (read-byte port)) port))
(read-char port))
;; path -> bytes
;; implementes read.c:read_compiled
(define (zo-parse [port (current-input-port)])
(define init-pos (file-position port))
(define mode (read-prefix port))
(case mode
[(#\T) (zo-parse-top port)]
[(#\D)
(struct mod-info (name start len))
(define mod-infos
(sort
(for/list ([i (in-range (read-simple-number port))])
(define size (read-simple-number port))
(define name (read-bytes size port))
(define start (read-simple-number port))
(define len (read-simple-number port))
(define left (read-simple-number port))
(define right (read-simple-number port))
(define name-p (open-input-bytes name))
(mod-info (let loop ()
(define c (read-byte name-p))
(if (eof-object? c)
null
(cons (string->symbol
(bytes->string/utf-8 (read-bytes (if (= c 255)
(read-simple-number port)
c)
name-p)))
(loop))))
start
len))
<
#:key mod-info-start))
(define tops
(for/list ([mod-info (in-list mod-infos)])
(define pos (file-position port))
(unless (= (- pos init-pos) (mod-info-start mod-info))
(error 'zo-parse
"next module expected at ~a, currently at ~a"
(+ init-pos (mod-info-start mod-info)) pos))
(unless (eq? (read-prefix port) #\T)
(error 'zo-parse "expected a module"))
(define top (zo-parse-top port #f))
(define m (compilation-top-code top))
(unless (mod? m)
(error 'zo-parse "expected a module"))
(unless (equal? (mod-info-name mod-info)
(if (symbol? (mod-name m))
'()
(cdr (mod-name m))))
(error 'zo-parse "module name mismatch"))
top))
(define avail (for/hash ([mod-info (in-list mod-infos)]
[top (in-list tops)])
(values (mod-info-name mod-info) top)))
(unless (hash-ref avail '() #f)
(error 'zo-parse "no root module in directory"))
(define-values (pre-subs post-subs seen)
(for/fold ([pre-subs (hash)] [post-subs (hash)] [seen (hash)]) ([mod-info (in-list mod-infos)])
(if (null? (mod-info-name mod-info))
(values pre-subs post-subs (hash-set seen '() #t))
(let ()
(define name (mod-info-name mod-info))
(define prefix (take name (sub1 (length name))))
(unless (hash-ref avail prefix #f)
(error 'zo-parse "no parent module for ~s" name))
(define (add subs)
(hash-set subs prefix (cons name (hash-ref subs prefix '()))))
(define new-seen (hash-set seen name #t))
(if (hash-ref seen prefix #f)
(values pre-subs (add post-subs) new-seen)
(values (add pre-subs) post-subs new-seen))))))
(define (get-all prefix)
(struct-copy mod
(compilation-top-code (hash-ref avail prefix))
[pre-submodules (map get-all (reverse (hash-ref pre-subs prefix '())))]
[post-submodules (map get-all (reverse (hash-ref post-subs prefix '())))]))
(struct-copy compilation-top (hash-ref avail '())
[code (get-all '())])]
[else
(error 'zo-parse "bad file format specifier")]))
(define (zo-parse-top [port (current-input-port)] [check-end? #t])
;; Skip module hash code
(read-bytes 20 port)
@ -1062,8 +1158,9 @@
(file-position port (+ rst-start size*))
(unless (eof-object? (read-byte port))
(error 'zo-parse "File too big"))
(when check-end?
(unless (eof-object? (read-byte port))
(error 'zo-parse "File too big")))
(define nr (make-not-ready))
(define symtab

6
collects/compiler/zo-structs.rkt
View File

@ -106,7 +106,7 @@
[max-let-depth exact-nonnegative-integer?]
[dummy (or/c toplevel? #f)]))
(define-form-struct (mod form) ([name symbol?]
(define-form-struct (mod form) ([name (or/c symbol? (listof symbol?))]
[srcname symbol?]
[self-modidx module-path-index?]
[prefix prefix?]
@ -124,7 +124,9 @@
[max-let-depth exact-nonnegative-integer?]
[dummy toplevel?]
[lang-info (or/c #f (vector/c module-path? symbol? any/c))]
[internal-context (or/c #f #t stx?)]))
[internal-context (or/c #f #t stx?)]
[pre-submodules (listof mod?)]
[post-submodules (listof mod?)]))
(define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)]
[flags (listof (or/c 'preserves-marks 'is-method 'single-result

39
collects/tests/compiler/zo.rkt
View File

@ -21,6 +21,42 @@
(define s 10)
(provide t (protect-out s))))
(define ex-mod3
'(module m racket/base
(module* a racket/base
(provide a)
(define a 1)
(module* a+ racket/base
(define a+ 1.1)))
(module* b racket/base
(require (submod "." ".." a))
(provide b)
(define b (+ a 1)))))
(define ex-mod4
'(module m racket/base
(module a racket/base
(provide a)
(define a 1)
(module a+ racket/base
(define a+ 1.1)))
(module b racket/base
(require (submod "." ".." a))
(provide b)
(define b (+ a 1)))))
(define ex-mod5
'(module m racket/base
(module a racket/base
(provide a)
(define a 1)
(module* a+ racket/base
(define a+ 1.1)))
(module* b racket/base
(require (submod "." ".." a))
(provide b)
(define b (+ a 1)))))
(define (check ex-mod)
(let ([c (parameterize ([current-namespace (make-base-namespace)])
(compile ex-mod))])
@ -36,5 +72,4 @@
(unless (equal? (to-string p) (to-string p2))
(error 'zo "failed on example: ~e" ex-mod))))))))
(check ex-mod1)
(check ex-mod2)
(for-each check (list ex-mod1 ex-mod2 ex-mod3 ex-mod4 ex-mod5))

13
collects/tests/racket/embed-me15-one.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang racket/base
(define two 2)
(provide two)
(module* one #f
(require (submod "." ".." three))
(define one 1)
(provide one two three))
(module three racket/base
(define three 3)
(provide three))

5
collects/tests/racket/embed-me15.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang racket/base
(require (submod "embed-me15-one.rkt" one))
(printf "This is ~a.\n" (+ 9 one two three))

1
collects/tests/racket/embed.rktl
View File

@ -223,6 +223,7 @@
(one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t)
(one-mz-test "embed-me13.rkt" "This is 14\n" #f)
(one-mz-test "embed-me14.rkt" "This is 14\n" #f)
(one-mz-test "embed-me15.rkt" "This is 15\n" #f)
;; Try unicode expr and cmdline:
(prepare dest "unicode")