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

add ++aux' flag to raco exe'

Browse Source 
original commit: ca0d7b5ef4
This commit is contained in:
Matthew Flatt 2011-09-09 10:30:02 -06:00
commit c626b6fc7c
13 changed files with 237 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/compiler/commands/exe.rkt
View File

@ -2,6 +2,7 @@
(require scheme/cmdline
raco/command-name
compiler/private/embed
launcher/launcher
dynext/file)
(define verbose (make-parameter #f))
@ -40,6 +41,11 @@
[("--cgc") "Generate using CGC variant"
(3m #f)]
#:multi
[("++aux") aux-file "Extra executable info (based on <aux-file> suffix)"
(let ([auxes (extract-aux-from-path (path->complete-path aux-file))])
(when (null? auxes)
(printf " warning: no recognized information from ~s\n" aux-file))
(exe-aux (append auxes (exe-aux))))]
[("++lib") lib "Embed <lib> in executable"
(exe-embedded-libraries (append (exe-embedded-libraries) (list lib)))]
[("++exf") flag "Add flag to embed in executable"

2
collects/compiler/commands/make.rkt
View File

@ -66,7 +66,7 @@
(lambda (p)
(set! did-one? #t)
(when (verbose)
(printf " making ~s\n" (path->string p))))])
(printf " making ~s\n" p)))])
(for ([file source-files])
(unless (file-exists? file)
(error mzc-symbol "file does not exist: ~a" file))

25
collects/compiler/decompile.rkt
View File

@ -164,16 +164,20 @@
(define (decompile-module mod-form stack stx-ht)
(match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported
[(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported
max-let-depth dummy lang-info internal-context))
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]
[(stack) (append '(#%modvars) stack)]
[(closed) (make-hasheq)])
`(module ,name ....
,@defns
,@(map (lambda (form)
(decompile-form form globs stack closed stx-ht))
syntax-body)
,@(for/list ([b (in-list syntax-bodies)])
(let loop ([n (sub1 (car b))])
(if (zero? n)
(cons 'begin
(for/list ([form (in-list (cdr b))])
(decompile-form form globs stack closed stx-ht)))
(list 'begin-for-syntax (loop (sub1 n))))))
,@(map (lambda (form)
(decompile-form form globs stack closed stx-ht))
body)))]
@ -190,18 +194,19 @@
(list-ref/protect (glob-desc-vars globs) pos 'def-vals)]))
ids)
,(decompile-expr rhs globs stack closed))]
[(struct def-syntaxes (ids rhs prefix max-let-depth))
[(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
`(define-syntaxes ,ids
,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(let ()
,@defns
,(decompile-form rhs globs '(#%globals) closed stx-ht))))]
[(struct def-for-syntax (ids rhs prefix max-let-depth))
`(define-values-for-syntax ,ids
,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(let ()
[(struct seq-for-syntax (exprs prefix max-let-depth dummy))
`(begin-for-syntax
,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(let ()
,@defns
,(decompile-form rhs globs '(#%globals) closed stx-ht))))]
,@(for/list ([rhs (in-list exprs)])
(decompile-form rhs globs '(#%globals) closed stx-ht)))))]
[(struct seq (forms))
`(begin ,@(map (lambda (form)
(decompile-form form globs stack closed stx-ht))

4
collects/compiler/demodularizer/gc-toplevels.rkt
View File

@ -64,7 +64,7 @@
(build-graph! new-lhs rhs)]
[(? def-syntaxes?)
(error 'build-graph "Doesn't handle syntax")]
[(? def-for-syntax?)
[(? seq-for-syntax?)
(error 'build-graph "Doesn't handle syntax")]
[(struct req (reqs dummy))
(build-graph! lhs dummy)]
@ -197,7 +197,7 @@
#f)]
[(? def-syntaxes?)
(error 'gc-tls "Doesn't handle syntax")]
[(? def-for-syntax?)
[(? seq-for-syntax?)
(error 'gc-tls "Doesn't handle syntax")]
[(struct req (reqs dummy))
(make-req reqs (update dummy))]

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

@ -108,7 +108,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-body unexported mod-max-let-depth dummy lang-info internal-context))
[(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies
unexported mod-max-let-depth dummy lang-info internal-context))
(define toplevel-offset (length (prefix-toplevels top-prefix)))
(define topsyntax-offset (length (prefix-stxs top-prefix)))
(define lift-offset (prefix-num-lifts top-prefix))

2
collects/compiler/demodularizer/module.rkt
View File

@ -24,7 +24,7 @@
(list (cons 0 requires))
new-forms
empty ; syntax-body
(list empty empty empty) ; unexported
(list) ; unexported
max-let-depth
(make-toplevel 0 0 #f #f) ; dummy
lang-info

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

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

2
collects/compiler/demodularizer/update-toplevels.rkt
View File

@ -10,7 +10,7 @@
(update rhs))]
[(? def-syntaxes?)
(error 'increment "Doesn't handle syntax")]
[(? def-for-syntax?)
[(? seq-for-syntax?)
(error 'increment "Doesn't handle syntax")]
[(struct req (reqs dummy))
(make-req reqs (update dummy))]

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

@ -158,7 +158,7 @@
(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 begin-for-syntax-type-num 17)
(define set-bang-type-num 18)
(define boxenv-type-num 19)
(define begin0-sequence-type-num 20)
@ -256,8 +256,6 @@
(define BITS_PER_MZSHORT 32)
(define *dummy* #f)
(define (int->bytes x)
(integer->integer-bytes x
4
@ -522,21 +520,20 @@
(out-marshaled define-values-type-num
(list->vector (cons (protect-quote rhs) ids))
out)]
[(struct def-syntaxes (ids rhs prefix max-let-depth))
[(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
(out-marshaled define-syntaxes-type-num
(list->vector (list* (protect-quote rhs)
prefix
max-let-depth
*dummy*
dummy
ids))
out)]
[(struct def-for-syntax (ids rhs prefix max-let-depth))
(out-marshaled define-for-syntax-type-num
(list->vector (list* (protect-quote rhs)
prefix
max-let-depth
*dummy*
ids))
[(struct seq-for-syntax (rhs prefix max-let-depth dummy))
(out-marshaled begin-for-syntax-type-num
(vector (map protect-quote rhs)
prefix
max-let-depth
dummy)
out)]
[(struct beg0 (forms))
(out-marshaled begin0-sequence-type-num (map protect-quote forms) out)]
@ -825,7 +822,7 @@
(define (out-module mod-form out)
(match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported
[(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported
max-let-depth dummy lang-info internal-context))
(let* ([lookup-req (lambda (phase)
(let ([a (assq phase requires)])
@ -844,6 +841,11 @@
(if (ormap values p)
(list->vector p)
#f)))))]
[extract-unexported
(lambda (phase)
(let ([a (assq phase unexported)])
(and a
(cdr a))))]
[list->vector/#f (lambda (default l)
(if (andmap (lambda (x) (equal? x default)) l)
#f
@ -861,45 +863,54 @@
[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 (reverse
(for/list ([b (in-list syntax-bodies)])
(for/vector ([i (in-list (cdr b))])
(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 dummy))
(vector (maybe-one ids) rhs max-let-depth prefix #f)]
[(struct seq-for-syntax ((list rhs) prefix max-let-depth dummy))
(vector #f 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 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))))
(let* ([phase (car l)]
[all (append (cadr l) (caddr l))]
[protects (extract-protects phase)]
[unexported (extract-unexported phase)])
(append
(list phase)
(if (and (not protects)
(not unexported))
(list (void))
(let ([unexported (or unexported
'(() ()))])
(list (list->vector (cadr unexported))
(length (cadr unexported))
(list->vector (car unexported))
(length (car unexported))
protects)))
(list (list->vector/#f 0 (map provided-src-phase 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 (add1 (length syntax-bodies)) l)]
[l (cons prefix l)]
[l (cons dummy l)]
[l (cons max-let-depth l)]

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

@ -181,19 +181,19 @@
(cdr (vector->list v))
(vector-ref v 0)))
; XXX Allocates unnessary list
(define (read-define-syntaxes mk v)
(mk (list-tail (vector->list v) 4)
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
#;(vector-ref v 3)))
(define (read-define-syntax v)
(read-define-syntaxes make-def-syntaxes v))
(make-def-syntaxes (list-tail (vector->list v) 4)
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)))
(define (read-define-for-syntax v)
(read-define-syntaxes make-def-for-syntax v))
(define (read-begin-for-syntax v)
(make-seq-for-syntax
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)))
(define (read-set! v)
(make-assign (cadr v) (cddr v) (car v)))
@ -225,50 +225,65 @@
(lambda _ #t)
(lambda _ #t)))))
(define (split-phase-data rest n)
(let loop ([n n] [rest rest] [phase-accum null])
(cond
[(zero? n)
(values (reverse phase-accum) rest)]
[else
(let ([maybe-indirect (list-ref rest 1)])
(if (void? maybe-indirect)
;; no indirect or protect info:
(loop (sub1 n)
(list-tail rest 9)
(cons (take rest 9) phase-accum))
;; has indirect or protect info:
(loop (sub1 n)
(list-tail rest (+ 5 8))
(cons (take rest (+ 5 8)) phase-accum))))])))
(define (read-module v)
(match v
[`(,name ,srcname ,self-modidx ,lang-info ,functional? ,et-functional?
,rename ,max-let-depth ,dummy
,prefix
,indirect-et-provides ,num-indirect-et-provides
,indirect-syntax-provides ,num-indirect-syntax-provides
,indirect-provides ,num-indirect-provides
,protects ,et-protects
,prefix ,num-phases
,provide-phase-count . ,rest)
(let ([phase-data (take rest (* 8 provide-phase-count))])
(match (list-tail rest (* 8 provide-phase-count))
[`(,syntax-body ,body
,requires ,syntax-requires ,template-requires ,label-requires
,more-requires-count . ,more-requires)
(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
prefix (let loop ([l phase-data])
(if (null? l)
null
(let ([num-vars (list-ref l 6)]
[ps (for/list ([name (in-vector (list-ref l 5))]
[src (in-vector (list-ref l 4))]
[src-name (in-vector (list-ref l 3))]
[nom-src (or (list-ref l 2)
(in-cycle (in-value #f)))]
[src-phase (or (list-ref l 1)
(in-cycle (in-value #f)))]
[protected? (or (case (car l)
[(0) protects]
[(1) et-protects]
[else #f])
(in-cycle (in-value #f)))])
(make-provided name src src-name
(or nom-src src)
(if src-phase 1 0)
protected?))])
(if (null? ps)
(loop (list-tail l 8))
(cons
(list
(car l)
(take ps num-vars)
(drop ps num-vars))
(loop (list-tail l 8)))))))
prefix
;; provides:
(for/list ([l (in-list phase-data)])
(let* ([phase (list-ref l 0)]
[has-info? (not (void? (list-ref l 1)))]
[delta (if has-info? 5 1)]
[num-vars (list-ref l (+ delta 6))]
[num-all (list-ref l (+ delta 7))]
[ps (for/list ([name (in-vector (list-ref l (+ delta 5)))]
[src (in-vector (list-ref l (+ delta 4)))]
[src-name (in-vector (list-ref l (+ delta 3)))]
[nom-src (or (list-ref l (+ delta 2))
(in-cycle (in-value #f)))]
[src-phase (or (list-ref l (+ delta 1))
(in-cycle (in-value 0)))]
[protected? (cond
[(or (not has-info?)
(not (list-ref l 5)))
(in-cycle (in-value #f))]
[else (list-ref l 5)])])
(make-provided name src src-name
(or nom-src src)
src-phase
protected?))])
(list
phase
(take ps num-vars)
(drop ps num-vars))))
;; requires:
(list*
(cons 0 requires)
(cons 1 syntax-requires)
@ -276,20 +291,34 @@
(cons #f label-requires)
(for/list ([(phase reqs) (in-list* more-requires 2)])
(cons phase reqs)))
(vector->list body)
(map (lambda (sb)
(match sb
[(? def-syntaxes?) sb]
[(? def-for-syntax?) sb]
[`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
((if for-stx?
make-def-for-syntax
make-def-syntaxes)
(if (list? ids) ids (list ids)) expr prefix max-let-depth)]))
(vector->list syntax-body))
(list (vector->list indirect-provides)
(vector->list indirect-syntax-provides)
(vector->list indirect-et-provides))
;; body:
(vector->list (last bodies))
;; syntax-bodies: add phase to each list, break apart
(for/list ([b (cdr (reverse bodies))]
[i (in-naturals 1)])
(cons i
(for/list ([sb (in-vector b)])
(match sb
[`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
(if for-stx?
(make-seq-for-syntax (list expr) prefix max-let-depth #f)
(make-def-syntaxes
(if (list? ids) ids (list ids)) expr prefix max-let-depth #f))]
[else (error 'zo-parse "bad phase ~a body element: ~e" i sb)]))))
;; unexported:
(for/list ([l (in-list phase-data)]
#:when (not (void? (list-ref l 1))))
(let* ([phase (list-ref l 0)]
[indirect-syntax
;; could check: (list-ref l 2) should be size of vector:
(list-ref l 1)]
[indirect
;; could check: (list-ref l 4) should be size of vector:
(list-ref l 3)])
(list
phase
(vector->list indirect)
(vector->list indirect-syntax))))
max-let-depth
dummy
lang-info
@ -313,7 +342,7 @@
[(14) 'quote-syntax-type]
[(15) 'define-values-type]
[(16) 'define-syntaxes-type]
[(17) 'define-for-syntax-type]
[(17) 'begin-for-syntax-type]
[(18) 'set-bang-type]
[(19) 'boxenv-type]
[(20) 'begin0-sequence-type]
@ -350,7 +379,7 @@
(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 'begin-for-syntax-type read-begin-for-syntax)
(cons 'set-bang-type read-set!)
(cons 'boxenv-type read-boxenv)
(cons 'require-form-type read-require)

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

@ -80,7 +80,7 @@
[src (or/c module-path-index? #f)]
[src-name symbol?]
[nom-src any/c] ; should be (or/c module-path-index? #f)
[src-phase (or/c 0 1)]
[src-phase exact-nonnegative-integer?]
[protected? boolean?]))
(define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?]
@ -89,18 +89,19 @@
[ready? boolean?])) ; access binding via prefix array (which is on stack)
(define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin'
(define-form-struct (seq-for-syntax form) ([forms (listof (or/c form? any/c))] ; `begin-for-syntax'
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]
[dummy (or/c toplevel? #f)]))
;; Definitions (top level or within module):
(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol?
(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))]
[rhs (or/c expr? seq? any/c)]))
(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol?
(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))]
[rhs (or/c expr? seq? any/c)]
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]))
(define-form-struct (def-for-syntax form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol?
[rhs (or/c expr? seq? any/c)]
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]))
[max-let-depth exact-nonnegative-integer?]
[dummy (or/c toplevel? #f)]))
(define-form-struct (mod form) ([name symbol?]
[srcname symbol?]
@ -111,10 +112,12 @@
(listof provided?)))]
[requires (listof (cons/c (or/c exact-integer? #f)
(listof module-path-index?)))]
[body (listof (or/c form? any/c))]
[syntax-body (listof (or/c def-syntaxes? def-for-syntax?))]
[unexported (list/c (listof symbol?) (listof symbol?)
(listof symbol?))]
[body (listof (or/c form? any/c))]
[syntax-bodies (listof (cons/c exact-positive-integer?
(listof (or/c def-syntaxes? seq-for-syntax?))))]
[unexported (listof (list/c exact-nonnegative-integer?
(listof symbol?)
(listof symbol?)))]
[max-let-depth exact-nonnegative-integer?]
[dummy toplevel?]
[lang-info (or/c #f (vector/c module-path? symbol? any/c))]

1
collects/launcher/launcher-sig.rkt
View File

@ -46,6 +46,7 @@ mred-launcher-put-file-extension+style+filters
mzscheme-launcher-put-file-extension+style+filters
build-aux-from-path
extract-aux-from-path
current-launcher-variant
available-mred-variants
available-mzscheme-variants

40
collects/tests/compiler/zo.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang racket/base
(require racket/pretty
compiler/zo-parse
compiler/zo-marshal
compiler/decompile)
(define ex-mod1
'(module m racket
(begin-for-syntax
(define fs 10)
(list fs))
(define-syntax (m stx)
#'10)
(m)
(begin-for-syntax
(list fs))))
(define ex-mod2
'(module m racket
(define t 8)
(define s 10)
(provide t (protect-out s))))
(define (check ex-mod)
(let ([c (parameterize ([current-namespace (make-base-namespace)])
(compile ex-mod))])
(let ([o (open-output-bytes)])
(write c o)
(let ([p (zo-parse (open-input-bytes (get-output-bytes o)))])
(let ([b (zo-marshal p)])
(let ([p2 (zo-parse (open-input-bytes b))]
[to-string (lambda (p)
(let ([o (open-output-bytes)])
(print p o)
(get-output-string o)))])
(unless (equal? (to-string p) (to-string p2))
(error 'zo "failed on example: ~e" ex-mod))))))))
(check ex-mod1)
(check ex-mod2)