Compare commits
No commits in common. "fix-id-table-ref-thunks" and "master" have entirely different histories.
fix-id-tab
...
master
|
|
@ -82,8 +82,8 @@ in "<dir>/bin", packages in "<dir>/share/racket/pkgs", documentation
|
|||
in "<dir>/share/racket/doc", etc.
|
||||
|
||||
On Mac OS X, `make unix-style PREFIX=<dir>' builds and installs into
|
||||
"<dir>" (which must be an absolute path) with binaries in "<dir>/bin",
|
||||
packages in "<dir>/share/pkgs", documentation in "<dir>/doc", etc.
|
||||
"<dir>" (whichmust be an absolute path) with binaries in "<dir>/bin",
|
||||
packges in "<dir>/share/pkgs", documentation in "<dir>/doc", etc.
|
||||
|
||||
On Windows, Unix-style install is not supported.
|
||||
|
||||
|
|
@ -196,7 +196,7 @@ libraries. See the documentation for `raco setup' for information on
|
|||
the options.
|
||||
|
||||
For cross compilation, add configuration options to
|
||||
`CONFIGURE_ARGS_qq="..."' as described in the "README" of "racket/src",
|
||||
`CONFIGURE_ARGS_qq="..."' as descibed in the "README" of "racket/src",
|
||||
but also add a `PLAIN_RACKET=...' argument for the top-level makefile
|
||||
to specify the same executable as in an `--enable-racket=...' for
|
||||
`configure'.
|
||||
|
|
@ -212,7 +212,7 @@ If you want to install packages manually out of the "pkgs" directory,
|
|||
the `local-catalog' target creates a catalog as "racket/local/catalog"
|
||||
that merges the currently configured catalog's content with pointers
|
||||
to the packages in "pkgs". A Unix-style build works that way: it
|
||||
builds and installs minimal Racket, and then it installs packages out
|
||||
builds and installs minimal Racket, and then it installs packags out
|
||||
of a catalog that is created by `make local-catalog'.
|
||||
|
||||
To add a package catalog that is used after the content of "pkgs" but
|
||||
|
|
|
|||
34
README.md
34
README.md
|
|
@ -1,34 +0,0 @@
|
|||
[](https://travis-ci.org/racket/racket)
|
||||
[](https://ci.appveyor.com/project/plt/racket)
|
||||
|
||||
|
||||
This is the source code for the core of Racket. See
|
||||
"INSTALL.txt" for full information on building Racket.
|
||||
|
||||
To build the full Racket distribution from this repository, run `make`
|
||||
in the top-level directory. To build the Minimal Racket, run `make
|
||||
base`.
|
||||
|
||||
The rest of the Racket distribution source code is in other
|
||||
repositories under [the Racket GitHub
|
||||
organization](https://github.com/racket).
|
||||
|
||||
Contribute to Racket by submitting a pull request, joining the
|
||||
[development mailing list](https://lists.racket-lang.org), or visiting
|
||||
the IRC channel.
|
||||
|
||||
License
|
||||
-------
|
||||
|
||||
Racket
|
||||
Copyright (c) 2010-2016 PLT Design Inc.
|
||||
|
||||
Racket is distributed under the GNU Lesser General Public License
|
||||
(LGPL). This implies that you may link Racket into proprietary
|
||||
applications, provided you follow the rules stated in the LGPL. You can
|
||||
also modify Racket; if you distribute a modified version, you must
|
||||
distribute it under the terms of the LGPL, which in particular states
|
||||
that you must release the source code for the modified software.
|
||||
|
||||
See racket/src/COPYING_LESSER.txt for more information.
|
||||
17
README.txt
Normal file
17
README.txt
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
This is the source code for the main Racket distribution. See
|
||||
"INSTALL.txt" for information on building Racket.
|
||||
|
||||
License
|
||||
-------
|
||||
|
||||
Racket
|
||||
Copyright (c) 2010-2016 PLT Design Inc.
|
||||
|
||||
Racket is distributed under the GNU Lesser General Public License
|
||||
(LGPL). This implies that you may link Racket into proprietary
|
||||
applications, provided you follow the rules stated in the LGPL. You can
|
||||
also modify Racket; if you distribute a modified version, you must
|
||||
distribute it under the terms of the LGPL, which in particular states
|
||||
that you must release the source code for the modified software.
|
||||
|
||||
See racket/src/COPYING_LESSER.txt for more information.
|
||||
|
|
@ -16,7 +16,15 @@
|
|||
(make-meta-reader
|
||||
'at-exp
|
||||
"language path"
|
||||
lang-reader-module-paths
|
||||
(lambda (bstr)
|
||||
(let* ([str (bytes->string/latin-1 bstr)]
|
||||
[sym (string->symbol str)])
|
||||
(and (module-path? sym)
|
||||
(vector
|
||||
;; try submod first:
|
||||
`(submod ,sym reader)
|
||||
;; fall back to /lang/reader:
|
||||
(string->symbol (string-append str "/lang/reader"))))))
|
||||
wrap-reader
|
||||
(lambda (orig-read-syntax)
|
||||
(define read-syntax (wrap-reader orig-read-syntax))
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
|
||||
(define collection 'multi)
|
||||
|
||||
(define version "6.7.0.2")
|
||||
(define version "6.4.0.15")
|
||||
|
||||
(define deps `("racket-lib"
|
||||
["racket" #:version ,version]))
|
||||
|
|
|
|||
|
|
@ -1,11 +0,0 @@
|
|||
compiler-lib
|
||||
Copyright (c) 2010-2014 PLT Design Inc.
|
||||
|
||||
This package is distributed under the GNU Lesser General Public
|
||||
License (LGPL). This means that you can link this package into proprietary
|
||||
applications, provided you follow the rules stated in the LGPL. You
|
||||
can also modify this package; if you distribute a modified version,
|
||||
you must distribute it under the terms of the LGPL, which in
|
||||
particular means that you must release the source code for the
|
||||
modified software. See http://www.gnu.org/copyleft/lesser.html
|
||||
for more information.
|
||||
|
|
@ -1,94 +0,0 @@
|
|||
|
||||
(module bundle-dist racket/base
|
||||
(require racket/file
|
||||
(only-in racket/base lambda)
|
||||
racket/path
|
||||
racket/system
|
||||
file/zip
|
||||
file/tar)
|
||||
|
||||
(provide bundle-put-file-extension+style+filters
|
||||
bundle-directory)
|
||||
|
||||
(define (bundle-file-suffix)
|
||||
(case (system-type)
|
||||
[(macosx) "dmg"]
|
||||
[(windows) "zip"]
|
||||
[(unix) "tgz"]))
|
||||
|
||||
(define (bundle-put-file-extension+style+filters)
|
||||
(values (bundle-file-suffix)
|
||||
null
|
||||
(case (system-type)
|
||||
[(windows) '(("Zip file" "*.zip"))]
|
||||
[(macosx) '(("Disk image" "*.dmg"))]
|
||||
[(unix) '(("Gzipped tar file" "*.tgz"))])))
|
||||
|
||||
(define (add-suffix name suffix)
|
||||
(if (filename-extension name)
|
||||
name
|
||||
(path-replace-suffix name
|
||||
(string->bytes/utf-8 (string-append "." suffix)))))
|
||||
|
||||
(define (with-prepared-directory dir for-exe? k)
|
||||
;; If `dir' contains multiple files, create a new
|
||||
;; directory that contains a copy of `dir'
|
||||
(if (and for-exe?
|
||||
(= 1 (length (directory-list dir))))
|
||||
(k dir)
|
||||
(let ([temp-dir (make-temporary-file "bundle-tmp-~a" 'directory)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(let ([dest
|
||||
(let-values ([(base name dir?) (split-path dir)])
|
||||
(build-path temp-dir name))])
|
||||
(make-directory dest)
|
||||
(let loop ([src dir][dest dest])
|
||||
(for-each (lambda (f)
|
||||
(let ([src (build-path src f)]
|
||||
[dest (build-path dest f)])
|
||||
(cond
|
||||
[(directory-exists? src)
|
||||
(make-directory dest)
|
||||
(loop src dest)]
|
||||
[(file-exists? src)
|
||||
(copy-file src dest)
|
||||
(file-or-directory-modify-seconds
|
||||
dest
|
||||
(file-or-directory-modify-seconds src))])))
|
||||
(directory-list src))))
|
||||
(k temp-dir))
|
||||
(lambda () (delete-directory/files temp-dir))))))
|
||||
|
||||
(define bundle-directory
|
||||
(lambda (target dir [for-exe? #f])
|
||||
(let ([target (add-suffix target (bundle-file-suffix))])
|
||||
(case (system-type)
|
||||
[(macosx)
|
||||
(with-prepared-directory
|
||||
dir for-exe?
|
||||
(lambda (dir)
|
||||
(let* ([cout (open-output-bytes)]
|
||||
[cerr (open-output-bytes)]
|
||||
[cin (open-input-bytes #"")]
|
||||
[p (process*/ports
|
||||
cout cin cerr
|
||||
"/usr/bin/hdiutil"
|
||||
"create" "-format" "UDZO"
|
||||
"-imagekey" "zlib-level=9"
|
||||
"-mode" "555"
|
||||
"-volname" (path->string
|
||||
(path-replace-suffix (file-name-from-path target) #""))
|
||||
"-srcfolder" (path->string (cleanse-path (path->complete-path dir)))
|
||||
(path->string (cleanse-path (path->complete-path target))))])
|
||||
((list-ref p 4) 'wait)
|
||||
(unless (eq? ((list-ref p 4) 'status) 'done-ok)
|
||||
(error 'bundle-directory
|
||||
"error bundling: ~a"
|
||||
(regexp-replace #rx"[\r\n]*$" (get-output-string cerr) ""))))))]
|
||||
[(windows unix)
|
||||
(let-values ([(base name dir?) (split-path (path->complete-path dir))])
|
||||
(parameterize ([current-directory base])
|
||||
((if (eq? 'unix (system-type)) tar-gzip zip) target name)))]
|
||||
[else (error 'bundle-directory "don't know how")])))))
|
||||
|
|
@ -1,91 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
raco/command-name
|
||||
compiler/zo-parse
|
||||
compiler/decompile
|
||||
compiler/compilation-path
|
||||
racket/pretty
|
||||
racket/format)
|
||||
|
||||
(define (get-name)
|
||||
(string->symbol (short-program+command-name)))
|
||||
|
||||
(define force? #f)
|
||||
|
||||
(define source-files
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("--force") "Ignore timestamp mimatch on associated \".zo\""
|
||||
(set! force? #t)]
|
||||
[("--columns" "-n") n "Format for <n> columns"
|
||||
(let ([num (string->number n)])
|
||||
(unless (exact-positive-integer? num)
|
||||
(raise-user-error (get-name)
|
||||
"not a valid column count: ~a" n))
|
||||
(pretty-print-columns num))]
|
||||
#:args source-or-bytecode-file
|
||||
source-or-bytecode-file))
|
||||
|
||||
(define (check-files orig-file alt-file)
|
||||
(cond
|
||||
[(not (file-exists? alt-file))
|
||||
(cond
|
||||
[(file-exists? orig-file)
|
||||
(unless (is-bytecode-file? orig-file)
|
||||
(raise-user-error (get-name)
|
||||
(~a "not a bytecode file, and no associated \".zo\" file;\n"
|
||||
" consider using `raco make` to compile the source file to bytecode\n"
|
||||
" path: ~a\n"
|
||||
" tried associated path: ~a")
|
||||
orig-file
|
||||
alt-file))]
|
||||
[else
|
||||
(raise-user-error (get-name)
|
||||
(~a "no such file, and no associated \".zo\" file\n"
|
||||
" path: ~a\n"
|
||||
" tried associated path: ~a")
|
||||
orig-file
|
||||
alt-file)])]
|
||||
[(not (is-bytecode-file? alt-file))
|
||||
(raise-user-error (get-name)
|
||||
(~a "associated \".zo\" file is not a bytecode file\n"
|
||||
" original path: ~a\n"
|
||||
" associated path: ~a")
|
||||
orig-file
|
||||
alt-file)]
|
||||
[(and (not force?)
|
||||
((file-or-directory-modify-seconds orig-file
|
||||
#f
|
||||
(lambda () -inf.0))
|
||||
. > .
|
||||
(file-or-directory-modify-seconds alt-file)))
|
||||
;; return a warning:
|
||||
(raise-user-error (get-name)
|
||||
(~a "associated \".zo\" file's date is older than given file's date;\n"
|
||||
" consider using `raco make` to rebuild the source file, or use `--force`\n"
|
||||
" to skip the date check\n"
|
||||
" original path: ~a\n"
|
||||
" associated path: ~a")
|
||||
orig-file
|
||||
alt-file)]))
|
||||
|
||||
(define (is-bytecode-file? orig-file)
|
||||
(call-with-input-file*
|
||||
orig-file
|
||||
(lambda (i)
|
||||
(equal? #"#~" (read-bytes 2 i)))))
|
||||
|
||||
(for ([zo-file source-files])
|
||||
(let ([zo-file (path->complete-path zo-file)])
|
||||
(let-values ([(base name dir?) (split-path zo-file)])
|
||||
(let ([alt-file (get-compilation-bytecode-file zo-file)])
|
||||
(check-files zo-file alt-file)
|
||||
(parameterize ([current-load-relative-directory base]
|
||||
[print-graph #t])
|
||||
(pretty-write
|
||||
(decompile
|
||||
(call-with-input-file*
|
||||
(if (file-exists? alt-file) alt-file zo-file)
|
||||
(lambda (in)
|
||||
(zo-parse in))))))))))
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
raco/command-name
|
||||
compiler/distribute)
|
||||
|
||||
(define verbose (make-parameter #f))
|
||||
(define exe-embedded-collects-path (make-parameter #f))
|
||||
(define exe-dir-add-collects-dirs (make-parameter null))
|
||||
|
||||
(define-values (dest-dir source-files)
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("--collects-path") path "Set <path> as main collects for executables"
|
||||
(exe-embedded-collects-path path)]
|
||||
#:multi
|
||||
[("++collects-copy") dir "Add collects in <dir> to directory"
|
||||
(exe-dir-add-collects-dirs (append (exe-dir-add-collects-dirs) (list dir)))]
|
||||
#:once-each
|
||||
[("-v") "Verbose mode"
|
||||
(verbose #t)]
|
||||
#:args (dest-dir . executable)
|
||||
(values dest-dir executable)))
|
||||
|
||||
(assemble-distribution
|
||||
dest-dir
|
||||
source-files
|
||||
#:collects-path (exe-embedded-collects-path)
|
||||
#:copy-collects (exe-dir-add-collects-dirs))
|
||||
(when (verbose)
|
||||
(printf " [output to \"~a\"]\n" dest-dir))
|
||||
|
||||
(module test racket/base)
|
||||
|
|
@ -1,155 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
raco/command-name
|
||||
compiler/private/embed
|
||||
launcher/launcher
|
||||
dynext/file
|
||||
setup/dirs)
|
||||
|
||||
(define verbose (make-parameter #f))
|
||||
(define very-verbose (make-parameter #f))
|
||||
|
||||
(define gui (make-parameter #f))
|
||||
(define 3m (make-parameter #t))
|
||||
(define launcher (make-parameter #f))
|
||||
|
||||
(define exe-output (make-parameter #f))
|
||||
(define exe-embedded-flags (make-parameter '("-U" "--")))
|
||||
(define exe-embedded-libraries (make-parameter null))
|
||||
(define exe-aux (make-parameter null))
|
||||
(define exe-embedded-config-path (make-parameter "etc"))
|
||||
(define exe-embedded-collects-path (make-parameter null))
|
||||
(define exe-embedded-collects-dest (make-parameter #f))
|
||||
|
||||
(define source-file
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("-o") file "Write executable as <file>"
|
||||
(exe-output file)]
|
||||
[("--gui") "Generate GUI executable"
|
||||
(gui #t)]
|
||||
[("-l" "--launcher") "Generate a launcher"
|
||||
(when (or (find-addon-tethered-gui-bin-dir)
|
||||
(find-addon-tethered-console-bin-dir))
|
||||
;; When an addon-executable directory is configured, treat the
|
||||
;; addon directory more like an installation directory, instead
|
||||
;; of a user-specific directory: record it, and remove the -U
|
||||
;; flag (if any)
|
||||
(exe-embedded-flags
|
||||
(append
|
||||
(list "-A" (path->string (find-system-path 'addon-dir)))
|
||||
(remove "-U" (exe-embedded-flags)))))
|
||||
(launcher #t)]
|
||||
[("--config-path") path "Set <path> as configuration directory for executable"
|
||||
(exe-embedded-config-path path)]
|
||||
[("--collects-path") path "Set <path> as main collects for executable"
|
||||
(exe-embedded-collects-path path)]
|
||||
[("--collects-dest") dir "Write collection code to <dir>"
|
||||
(exe-embedded-collects-dest dir)]
|
||||
[("--ico") .ico-file "Set Windows icon for executable"
|
||||
(exe-aux (cons (cons 'ico .ico-file) (exe-aux)))]
|
||||
[("--icns") .icns-file "Set Mac OS X icon for executable"
|
||||
(exe-aux (cons (cons 'icns .icns-file) (exe-aux)))]
|
||||
[("--orig-exe") "Use original executable instead of stub"
|
||||
(exe-aux (cons (cons 'original-exe? #t) (exe-aux)))]
|
||||
[("--3m") "Generate using 3m variant"
|
||||
(3m #t)]
|
||||
[("--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"
|
||||
(exe-embedded-flags (append (exe-embedded-flags) (list flag)))]
|
||||
[("--exf") flag "Remove flag to embed in executable"
|
||||
(exe-embedded-flags (remove flag (exe-embedded-flags)))]
|
||||
[("--exf-clear") "Clear flags to embed in executable"
|
||||
(exe-embedded-flags null)]
|
||||
[("--exf-show") "Show flags to embed in executable"
|
||||
(printf "Flags to embed: ~s\n" (exe-embedded-flags))]
|
||||
#:once-each
|
||||
[("-v") "Verbose mode"
|
||||
(verbose #t)]
|
||||
[("--vv") "Very verbose mode"
|
||||
(verbose #t)
|
||||
(very-verbose #t)]
|
||||
#:args (source-file)
|
||||
source-file))
|
||||
|
||||
(let ([dest (mzc:embedding-executable-add-suffix
|
||||
(or (exe-output)
|
||||
(extract-base-filename/ss source-file
|
||||
(string->symbol (short-program+command-name))))
|
||||
(gui))])
|
||||
(unless (file-exists? source-file)
|
||||
(raise-user-error (string->symbol (short-program+command-name))
|
||||
"source file does not exist\n path: ~a" source-file))
|
||||
(with-handlers ([exn:fail:filesystem? (lambda (exn) (void))])
|
||||
(call-with-input-file* dest
|
||||
(lambda (dest-in)
|
||||
(call-with-input-file* source-file
|
||||
(lambda (source-in)
|
||||
(when (equal? (port-file-identity dest-in)
|
||||
(port-file-identity source-in))
|
||||
(raise-user-error (string->symbol (short-program+command-name))
|
||||
(string-append
|
||||
"source file is the same as the destination file"
|
||||
"\n source path: ~a"
|
||||
"\n destination path: ~a")
|
||||
source-file
|
||||
dest)))))))
|
||||
(cond
|
||||
[(launcher)
|
||||
(parameterize ([current-launcher-variant (if (3m) '3m 'cgc)])
|
||||
((if (gui)
|
||||
make-gracket-launcher
|
||||
make-racket-launcher)
|
||||
(append (list "-t" (path->string (path->complete-path source-file)))
|
||||
(exe-embedded-flags))
|
||||
dest
|
||||
(exe-aux)))]
|
||||
[else
|
||||
(define mod-sym (string->symbol
|
||||
(format "#%mzc:~a"
|
||||
(let-values ([(base name dir?)
|
||||
(split-path source-file)])
|
||||
(path->bytes (path-replace-suffix name #""))))))
|
||||
(mzc:create-embedding-executable
|
||||
dest
|
||||
#:mred? (gui)
|
||||
#:variant (if (3m) '3m 'cgc)
|
||||
#:verbose? (very-verbose)
|
||||
#:modules (cons `(#%mzc: (file ,source-file) (main configure-runtime))
|
||||
(map (lambda (l) `(#t (lib ,l)))
|
||||
(exe-embedded-libraries)))
|
||||
#:configure-via-first-module? #t
|
||||
#:early-literal-expressions
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(define cr-sym (string->symbol (format "~a(configure-runtime)" mod-sym)))
|
||||
(list
|
||||
(compile
|
||||
`(when (module-declared? '',cr-sym)
|
||||
(dynamic-require '',cr-sym #f)))))
|
||||
#:literal-expression
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(define main-sym (string->symbol (format "~a(main)" mod-sym)))
|
||||
(compile
|
||||
`(begin
|
||||
(namespace-require '',mod-sym)
|
||||
(when (module-declared? '',main-sym)
|
||||
(dynamic-require '',main-sym #f)))))
|
||||
#:cmdline (exe-embedded-flags)
|
||||
#:collects-path (exe-embedded-collects-path)
|
||||
#:collects-dest (exe-embedded-collects-dest)
|
||||
#:aux (cons `(config-dir . ,(exe-embedded-config-path))
|
||||
(exe-aux)))])
|
||||
(when (verbose)
|
||||
(printf " [output to \"~a\"]\n" dest)))
|
||||
|
||||
(module test racket/base)
|
||||
|
|
@ -1,42 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(module expand racket/base
|
||||
(require racket/cmdline
|
||||
raco/command-name
|
||||
racket/pretty)
|
||||
|
||||
(provide show-program)
|
||||
|
||||
(define (show-program expand)
|
||||
(define source-files
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("--columns" "-n") n "Format for <n> columns"
|
||||
(let ([num (string->number n)])
|
||||
(unless (exact-positive-integer? num)
|
||||
(raise-user-error (string->symbol (short-program+command-name))
|
||||
"not a valid column count: ~a" n))
|
||||
(pretty-print-columns num))]
|
||||
#:args source-file
|
||||
source-file))
|
||||
|
||||
(for ([src-file source-files])
|
||||
(let ([src-file (path->complete-path src-file)])
|
||||
(let-values ([(base name dir?) (split-path src-file)])
|
||||
(parameterize ([current-load-relative-directory base]
|
||||
[current-namespace (make-base-namespace)]
|
||||
[read-accept-reader #t])
|
||||
(call-with-input-file*
|
||||
src-file
|
||||
(lambda (in)
|
||||
(port-count-lines! in)
|
||||
(let loop ()
|
||||
(let ([e (read-syntax src-file in)])
|
||||
(unless (eof-object? e)
|
||||
(pretty-write (syntax->datum (expand e)))
|
||||
(loop))))))))))))
|
||||
|
||||
(require (submod "." expand))
|
||||
(show-program expand)
|
||||
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define raco-commands
|
||||
'(("make" compiler/commands/make "compile source to bytecode" 100)
|
||||
("exe" compiler/commands/exe "create executable" 20)
|
||||
("pack" compiler/commands/pack "pack files/collections into a .plt archive" #f)
|
||||
("unpack" compiler/commands/unpack "unpack files/collections from a .plt archive" #f)
|
||||
("decompile" compiler/commands/decompile "decompile bytecode" #f)
|
||||
("test" compiler/commands/test "run tests associated with files/directories" 15)
|
||||
("expand" compiler/commands/expand "macro-expand source" #f)
|
||||
("read" compiler/commands/read "read and pretty-print source" #f)
|
||||
("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f)
|
||||
("demodularize" compiler/demodularizer/batch "produce a whole program from a single module" #f)))
|
||||
|
||||
(define test-responsibles '(("test.rkt" jay)))
|
||||
|
|
@ -1,119 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
raco/command-name
|
||||
compiler/cm
|
||||
compiler/compiler
|
||||
compiler/compilation-path
|
||||
dynext/file
|
||||
setup/parallel-build
|
||||
setup/path-to-relative
|
||||
racket/match)
|
||||
|
||||
(module test racket/base)
|
||||
|
||||
(define verbose (make-parameter #f))
|
||||
(define very-verbose (make-parameter #f))
|
||||
(define disable-inlining (make-parameter #f))
|
||||
|
||||
(define disable-deps (make-parameter #f))
|
||||
(define disable-const (make-parameter #f))
|
||||
(define prefixes (make-parameter null))
|
||||
(define assume-primitives (make-parameter #t))
|
||||
(define worker-count (make-parameter 1))
|
||||
|
||||
(define mzc-symbol (string->symbol (short-program+command-name)))
|
||||
|
||||
(define source-files
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("-j") n "Compile with up to <n> tasks in parallel"
|
||||
(let ([num (string->number n)])
|
||||
(unless num (raise-user-error (format "~a: bad count for -j: ~s"
|
||||
(short-program+command-name)
|
||||
n)))
|
||||
(worker-count num))]
|
||||
[("--disable-inline") "Disable procedure inlining during compilation"
|
||||
(disable-inlining #t)]
|
||||
[("--disable-constant") "Disable enforcement of module constants"
|
||||
(disable-const #t)]
|
||||
[("--no-deps") "Compile immediate files without updating dependencies"
|
||||
(disable-deps #t)]
|
||||
[("-p" "--prefix") file "Add elaboration-time prefix file for --no-deps"
|
||||
(prefixes (append (prefixes) (list file)))]
|
||||
[("--no-prim") "Do not assume `scheme' bindings at top level for --no-deps"
|
||||
(assume-primitives #f)]
|
||||
[("-v") "Verbose mode"
|
||||
(verbose #t)]
|
||||
[("--vv") "Very verbose mode"
|
||||
(verbose #t)
|
||||
(very-verbose #t)]
|
||||
#:args (file . another-file) (cons file another-file)))
|
||||
|
||||
(cond
|
||||
;; Just compile one file:
|
||||
[(disable-deps)
|
||||
(let ([prefix
|
||||
`(begin
|
||||
(require scheme)
|
||||
,(if (assume-primitives)
|
||||
'(void)
|
||||
'(namespace-require/copy 'scheme))
|
||||
,@(map (lambda (s) `(load ,s)) (prefixes))
|
||||
(void))])
|
||||
((compile-zos prefix #:verbose? (verbose))
|
||||
source-files
|
||||
'auto))]
|
||||
;; Normal make:
|
||||
[(= (worker-count) 1)
|
||||
(let ([n (make-base-empty-namespace)]
|
||||
[did-one? #f])
|
||||
(parameterize ([current-namespace n]
|
||||
[manager-trace-handler
|
||||
(if (very-verbose)
|
||||
(λ (p) (printf " ~a\n" p))
|
||||
(manager-trace-handler))]
|
||||
[manager-compile-notify-handler
|
||||
(lambda (p)
|
||||
(set! did-one? #t)
|
||||
(when (verbose)
|
||||
(printf " making ~s\n" p)))])
|
||||
(for ([file source-files])
|
||||
(unless (file-exists? file)
|
||||
(error mzc-symbol "file does not exist: ~a" file))
|
||||
(set! did-one? #f)
|
||||
(let ([name (extract-base-filename/ss file mzc-symbol)])
|
||||
(when (verbose)
|
||||
(printf "\"~a\":\n" file))
|
||||
(parameterize ([compile-context-preservation-enabled
|
||||
(disable-inlining)]
|
||||
[compile-enforce-module-constants
|
||||
(not (disable-const))])
|
||||
(managed-compile-zo file))
|
||||
(when (verbose)
|
||||
(printf " [~a \"~a\"]\n"
|
||||
(if did-one? "output to" "already up-to-date at")
|
||||
(get-compilation-bytecode-file file)))))))]
|
||||
;; Parallel make:
|
||||
[else
|
||||
(define path-cache (make-hash))
|
||||
(or (parallel-compile-files
|
||||
source-files
|
||||
#:worker-count (worker-count)
|
||||
#:handler (lambda (id type work msg out err)
|
||||
(define (->rel p)
|
||||
(path->relative-string/library p #:cache path-cache))
|
||||
(match type
|
||||
['start (when (verbose) (printf " ~a making ~a\n" id (->rel work)))]
|
||||
['done (when (verbose) (printf " ~a made ~a\n" id (->rel work)))]
|
||||
['output (printf " ~a output from: ~a\n~a~a" id work out err)]
|
||||
[else (printf " ~a error compiling ~a\n~a\n~a~a" id work msg out err)]))
|
||||
#:options (let ([cons-if-true (lambda (bool carv cdrv)
|
||||
(if bool
|
||||
(cons carv cdrv)
|
||||
cdrv))])
|
||||
(cons-if-true
|
||||
(very-verbose)
|
||||
'very-verbose
|
||||
(cons-if-true (disable-inlining) 'disable-inlining null))))
|
||||
(exit 1))])
|
||||
|
|
@ -1,99 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
raco/command-name
|
||||
setup/pack
|
||||
setup/getinfo
|
||||
compiler/distribute)
|
||||
|
||||
(define verbose (make-parameter #f))
|
||||
|
||||
(define collection? (make-parameter #f))
|
||||
|
||||
(define default-plt-name "archive")
|
||||
|
||||
(define plt-name (make-parameter default-plt-name))
|
||||
(define plt-files-replace (make-parameter #f))
|
||||
(define plt-files-plt-relative? (make-parameter #f))
|
||||
(define plt-files-plt-home-relative? (make-parameter #f))
|
||||
(define plt-force-install-dir? (make-parameter #f))
|
||||
(define plt-setup-collections (make-parameter null))
|
||||
(define plt-include-compiled (make-parameter #f))
|
||||
|
||||
(define mzc-symbol (string->symbol (short-program+command-name)))
|
||||
|
||||
(define-values (plt-output source-files)
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("--collect") "<path>s specify collections instead of files/dirs"
|
||||
(collection? #t)]
|
||||
[("--plt-name") name "Set the printed <name> describing the archive"
|
||||
(plt-name name)]
|
||||
[("--replace") "Files in archive replace existing files when unpacked"
|
||||
(plt-files-replace #t)]
|
||||
[("--at-plt") "Files/dirs in archive are relative to user's add-ons directory"
|
||||
(plt-files-plt-relative? #t)]
|
||||
#:once-any
|
||||
[("--all-users") "Files/dirs in archive go to PLT installation if writable"
|
||||
(plt-files-plt-home-relative? #t)]
|
||||
[("--force-all-users") "Files/dirs forced to PLT installation"
|
||||
(plt-files-plt-home-relative? #t) (plt-force-install-dir? #t)]
|
||||
#:once-each
|
||||
[("--include-compiled") "Include \"compiled\" subdirectories in the archive"
|
||||
(plt-include-compiled #t)]
|
||||
#:multi
|
||||
[("++setup") collect "Setup <collect> after the archive is unpacked"
|
||||
(plt-setup-collections (append (plt-setup-collections) (list collect)))]
|
||||
#:once-each
|
||||
[("-v") "Verbose mode"
|
||||
(verbose #t)]
|
||||
#:args (dest-file . path)
|
||||
(values dest-file path)))
|
||||
|
||||
(if (not (collection?))
|
||||
;; Files and directories
|
||||
(begin
|
||||
(for ([fd source-files])
|
||||
(unless (relative-path? fd)
|
||||
(error mzc-symbol
|
||||
"file/directory is not relative to the current directory: \"~a\""
|
||||
fd)))
|
||||
(pack-plt plt-output
|
||||
(plt-name)
|
||||
source-files
|
||||
#:collections (map list (plt-setup-collections))
|
||||
#:file-mode (if (plt-files-replace) 'file-replace 'file)
|
||||
#:plt-relative? (or (plt-files-plt-relative?)
|
||||
(plt-files-plt-home-relative?))
|
||||
#:at-plt-home? (plt-files-plt-home-relative?)
|
||||
#:test-plt-dirs (if (or (plt-force-install-dir?)
|
||||
(not (plt-files-plt-home-relative?)))
|
||||
#f
|
||||
'("collects" "doc" "include" "lib"))
|
||||
#:requires
|
||||
null)
|
||||
(when (verbose)
|
||||
(printf " [output to \"~a\"]\n" plt-output)))
|
||||
;; Collection
|
||||
(begin
|
||||
(pack-collections-plt
|
||||
plt-output
|
||||
(if (eq? default-plt-name (plt-name)) #f (plt-name))
|
||||
(map (lambda (sf)
|
||||
(let loop ([sf sf])
|
||||
(let ([m (regexp-match "^([^/]*)/(.*)$" sf)])
|
||||
(if m (cons (cadr m) (loop (caddr m))) (list sf)))))
|
||||
source-files)
|
||||
#:replace? (plt-files-replace)
|
||||
#:extra-setup-collections (map list (plt-setup-collections))
|
||||
#:file-filter (if (plt-include-compiled)
|
||||
(lambda (path)
|
||||
(or (regexp-match #rx#"compiled$" (path->bytes path))
|
||||
(std-filter path)))
|
||||
std-filter)
|
||||
#:at-plt-home? (plt-files-plt-home-relative?)
|
||||
#:test-plt-collects? (not (plt-force-install-dir?)))
|
||||
(when (verbose)
|
||||
(printf " [output to \"~a\"]\n" plt-output))))
|
||||
|
||||
(module test racket/base)
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (submod "expand.rkt" expand))
|
||||
|
||||
(show-program (lambda (e) e))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,102 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
raco/command-name
|
||||
setup/unpack
|
||||
racket/file
|
||||
racket/port
|
||||
racket/match
|
||||
racket/string
|
||||
racket/pretty)
|
||||
|
||||
(define verbose (make-parameter #f))
|
||||
|
||||
(define just-show? (make-parameter #f))
|
||||
(define replace? (make-parameter #f))
|
||||
(define show-config? (make-parameter #f))
|
||||
|
||||
(define mzc-symbol (string->symbol (short-program+command-name)))
|
||||
|
||||
(define files
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("-l" "--list") "just list archive content"
|
||||
(just-show? #t)]
|
||||
[("-c" "--config") "show archive configuration"
|
||||
(show-config? #t)]
|
||||
[("-f" "--force") "replace existing files when unpacking"
|
||||
(replace? #t)]
|
||||
#:args archive
|
||||
archive))
|
||||
|
||||
(define (desc->path dir)
|
||||
(if (path? dir)
|
||||
dir
|
||||
(apply build-path
|
||||
(symbol->string (car dir))
|
||||
(cdr dir))))
|
||||
|
||||
(for ([filename (in-list files)])
|
||||
(fold-plt-archive filename
|
||||
(lambda (config a)
|
||||
(when (show-config?)
|
||||
(match config
|
||||
[`(lambda (request failure)
|
||||
(case request
|
||||
((name) ,name)
|
||||
((unpacker) (quote mzscheme))
|
||||
((requires) (quote ,reqs))
|
||||
((conflicts) (quote ,conflicts))
|
||||
((plt-relative?) ,plt-rel?)
|
||||
((plt-home-relative?) ,plt-home-rel?)
|
||||
((test-plt-dirs) ,test-plt-dirs)
|
||||
(else (failure))))
|
||||
(printf "config:\n")
|
||||
(printf " name: ~s\n" name)
|
||||
(printf " requires:\n")
|
||||
(for ([c (in-list reqs)])
|
||||
(printf " ~s ~s\n" (string-join (car c) "/") (cadr c)))
|
||||
(printf " conflicts:\n")
|
||||
(for ([c (in-list conflicts)])
|
||||
(printf " ~s\n" (string-join c "/")))
|
||||
(cond
|
||||
[plt-home-rel? (printf " unpack to main installation\n")]
|
||||
[plt-rel? (printf " unpack to user add-ons\n")]
|
||||
[else (printf " unpack locally\n")])]
|
||||
[else
|
||||
(printf "config function:\n")
|
||||
(pretty-write config)]))
|
||||
a)
|
||||
(lambda (setup i a)
|
||||
(when (show-config?)
|
||||
(match setup
|
||||
[`(unit (import main-collects-parent-dir mzuntar) (export) (mzuntar void) (quote ,c))
|
||||
(printf "setup collections:\n")
|
||||
(for ([c (in-list c)])
|
||||
(printf " ~s\n" (string-join c "/")))]
|
||||
[else
|
||||
(printf "setup unit:\n")
|
||||
(pretty-write setup)]))
|
||||
a)
|
||||
(lambda (dir a)
|
||||
(unless (eq? dir 'same)
|
||||
(if (just-show?)
|
||||
(printf "~a\n" (path->directory-path (desc->path dir)))
|
||||
(make-directory* (desc->path dir))))
|
||||
a)
|
||||
(lambda (file i kind a)
|
||||
(if (just-show?)
|
||||
(printf "~a~a\n" (desc->path file)
|
||||
(if (eq? kind 'file-replace)
|
||||
" [replace]"
|
||||
""))
|
||||
(call-with-output-file*
|
||||
(desc->path file)
|
||||
#:exists (if (or (eq? kind 'file-replace)
|
||||
(replace?))
|
||||
'truncate/replace
|
||||
'error)
|
||||
(lambda (o)
|
||||
(copy-port i o))))
|
||||
a)
|
||||
(void)))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require compiler/compiler compiler/sig racket/unit)
|
||||
(provide compiler@)
|
||||
(define-unit-from-context compiler@ compiler^)
|
||||
|
|
@ -1,606 +0,0 @@
|
|||
#lang racket/base
|
||||
(require compiler/zo-parse
|
||||
syntax/modcollapse
|
||||
racket/port
|
||||
racket/match
|
||||
racket/list
|
||||
racket/set
|
||||
racket/path)
|
||||
|
||||
(provide decompile)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(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 ''#%extfl)
|
||||
(namespace-require ''#%futures)
|
||||
(namespace-require ''#%foreign)
|
||||
(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
|
||||
(open-input-bytes
|
||||
(with-output-to-bytes
|
||||
(λ () (write (cdr b)))))))])
|
||||
(let ([n (match v
|
||||
[(struct compilation-top (_ _ prefix (struct primval (n)))) n]
|
||||
[else #f])])
|
||||
(hash-set! table n (car b)))))
|
||||
table))
|
||||
|
||||
(define (list-ref/protect l pos who)
|
||||
(list-ref l pos)
|
||||
#;
|
||||
(if (pos . < . (length l))
|
||||
(list-ref l pos)
|
||||
`(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-struct glob-desc (vars num-tls num-stxs num-lifts))
|
||||
|
||||
;; Main entry:
|
||||
(define (decompile top)
|
||||
(let ([stx-ht (make-hasheq)])
|
||||
(match top
|
||||
[(struct compilation-top (max-let-depth binding-namess prefix form))
|
||||
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
|
||||
(expose-module-path-indexes
|
||||
`(begin
|
||||
,@defns
|
||||
,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht))))]
|
||||
[else (error 'decompile "unrecognized: ~e" top)])))
|
||||
|
||||
(define (expose-module-path-indexes e)
|
||||
;; This is a nearly general replace-in-graph function. (It seems like a lot
|
||||
;; of work to expose module path index content and sharing, though.)
|
||||
(define ht (make-hasheq))
|
||||
(define mconses null)
|
||||
(define (x-mcons a b)
|
||||
(define m (mcons a b))
|
||||
(set! mconses (cons (cons m (cons a b)) mconses))
|
||||
m)
|
||||
(define main
|
||||
(let loop ([e e])
|
||||
(cond
|
||||
[(hash-ref ht e #f)]
|
||||
[(module-path-index? e)
|
||||
(define ph (make-placeholder #f))
|
||||
(hash-set! ht e ph)
|
||||
(define-values (name base) (module-path-index-split e))
|
||||
(placeholder-set! ph (x-mcons '#%modidx
|
||||
(x-mcons (loop name)
|
||||
(x-mcons (loop base)
|
||||
null))))
|
||||
ph]
|
||||
[(pair? e)
|
||||
(define ph (make-placeholder #f))
|
||||
(hash-set! ht e ph)
|
||||
(placeholder-set! ph (cons (loop (car e))
|
||||
(loop (cdr e))))
|
||||
ph]
|
||||
[(mpair? e)
|
||||
(define m (mcons #f #f))
|
||||
(hash-set! ht e m)
|
||||
(set! mconses (cons (cons m (cons (loop (mcar e))
|
||||
(loop (mcdr e))))
|
||||
mconses))
|
||||
m]
|
||||
[(box? e)
|
||||
(define ph (make-placeholder #f))
|
||||
(hash-set! ht e ph)
|
||||
(placeholder-set! ph (box (loop (unbox e))))
|
||||
ph]
|
||||
[(vector? e)
|
||||
(define ph (make-placeholder #f))
|
||||
(hash-set! ht e ph)
|
||||
(placeholder-set! ph
|
||||
(for/vector #:length (vector-length e) ([i (in-vector e)])
|
||||
(loop i)))
|
||||
ph]
|
||||
[(hash? e)
|
||||
(define ph (make-placeholder #f))
|
||||
(hash-set! ht e ph)
|
||||
(placeholder-set! ph
|
||||
((cond
|
||||
[(hash-eq? ht)
|
||||
make-hasheq-placeholder]
|
||||
[(hash-eqv? ht)
|
||||
make-hasheqv-placeholder]
|
||||
[else make-hash-placeholder])
|
||||
(for/list ([(k v) (in-hash e)])
|
||||
(cons (loop k) (loop v)))))
|
||||
ph]
|
||||
[(prefab-struct-key e)
|
||||
=> (lambda (k)
|
||||
(define ph (make-placeholder #f))
|
||||
(hash-set! ht e ph)
|
||||
(placeholder-set! ph
|
||||
(apply make-prefab-struct
|
||||
k
|
||||
(map loop
|
||||
(cdr (vector->list (struct->vector e))))))
|
||||
ph)]
|
||||
[else
|
||||
e])))
|
||||
(define l (make-reader-graph (cons main mconses)))
|
||||
(for ([i (in-list (cdr l))])
|
||||
(set-mcar! (car i) (cadr i))
|
||||
(set-mcdr! (car i) (cddr i)))
|
||||
(car l))
|
||||
|
||||
(define (decompile-prefix a-prefix stx-ht)
|
||||
(match a-prefix
|
||||
[(struct prefix (num-lifts toplevels stxs src-insp-desc))
|
||||
(let ([lift-ids (for/list ([i (in-range num-lifts)])
|
||||
(gensym 'lift))]
|
||||
[stx-ids (map (lambda (i) (gensym 'stx))
|
||||
stxs)])
|
||||
(values (glob-desc
|
||||
(append
|
||||
(map (lambda (tl)
|
||||
(match tl
|
||||
[#f '#%linkage]
|
||||
[(? symbol?) (string->symbol (format "_~a" tl))]
|
||||
[(struct global-bucket (name))
|
||||
(string->symbol (format "_~a" name))]
|
||||
[(struct module-variable (modidx sym pos phase constantness))
|
||||
(if (and (module-path-index? modidx)
|
||||
(let-values ([(n b) (module-path-index-split modidx)])
|
||||
(and (not n) (not b))))
|
||||
(string->symbol (format "_~a" sym))
|
||||
(string->symbol (format "_~s~a@~s~a"
|
||||
sym
|
||||
(match constantness
|
||||
['constant ":c"]
|
||||
['fixed ":f"]
|
||||
[(function-shape a pm?)
|
||||
(if pm? ":P" ":p")]
|
||||
[(struct-type-shape c) ":t"]
|
||||
[(constructor-shape a) ":mk"]
|
||||
[(predicate-shape) ":?"]
|
||||
[(accessor-shape c) ":ref"]
|
||||
[(mutator-shape c) ":set!"]
|
||||
[else ""])
|
||||
(mpi->string modidx)
|
||||
(if (zero? phase)
|
||||
""
|
||||
(format "/~a" phase)))))]
|
||||
[else (error 'decompile-prefix "bad toplevel: ~e" tl)]))
|
||||
toplevels)
|
||||
stx-ids
|
||||
(if (null? stx-ids) null '(#%stx-array))
|
||||
lift-ids)
|
||||
(length toplevels)
|
||||
(length stxs)
|
||||
num-lifts)
|
||||
(list*
|
||||
`(quote inspector ,src-insp-desc)
|
||||
;; `(quote tls ,toplevels)
|
||||
(map (lambda (stx id)
|
||||
`(define ,id ,(if stx
|
||||
`(#%decode-syntax
|
||||
,(decompile-stx (stx-content stx) stx-ht))
|
||||
#f)))
|
||||
stxs stx-ids))))]
|
||||
[else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
|
||||
|
||||
(define (decompile-stx stx stx-ht)
|
||||
(or (hash-ref stx-ht stx #f)
|
||||
(let ([p (mcons #f #f)])
|
||||
(hash-set! stx-ht stx p)
|
||||
(match stx
|
||||
[(stx-obj datum wrap srcloc props tamper-status)
|
||||
(set-mcar! p (case tamper-status
|
||||
[(clean) 'wrap]
|
||||
[(tainted) 'wrap-tainted]
|
||||
[(armed) 'wrap-armed]))
|
||||
(set-mcdr! p (mcons
|
||||
(cond
|
||||
[(pair? datum)
|
||||
(cons (decompile-stx (car datum) stx-ht)
|
||||
(let loop ([l (cdr datum)])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(pair? l)
|
||||
(cons (decompile-stx (car l) stx-ht)
|
||||
(loop (cdr l)))]
|
||||
[else
|
||||
(decompile-stx l stx-ht)])))]
|
||||
[(vector? datum)
|
||||
(for/vector ([e (in-vector datum)])
|
||||
(decompile-stx e stx-ht))]
|
||||
[(box? datum)
|
||||
(box (decompile-stx (unbox datum) stx-ht))]
|
||||
[else datum])
|
||||
(let* ([l (mcons wrap null)]
|
||||
[l (if (hash-count props)
|
||||
(mcons props l)
|
||||
l)]
|
||||
[l (if srcloc
|
||||
(mcons srcloc l)
|
||||
l)])
|
||||
l)))
|
||||
p]))))
|
||||
|
||||
(define (mpi->string modidx)
|
||||
(cond
|
||||
[(symbol? modidx) modidx]
|
||||
[else
|
||||
(collapse-module-path-index modidx)]))
|
||||
|
||||
(define (decompile-module mod-form orig-stack stx-ht mod-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 binding-names
|
||||
flags pre-submodules post-submodules))
|
||||
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]
|
||||
[(stack) (append '(#%modvars) orig-stack)]
|
||||
[(closed) (make-hasheq)])
|
||||
`(,mod-name ,(if (symbol? name) name (last name)) ....
|
||||
(quote self ,self-modidx)
|
||||
(quote internal-context
|
||||
,(if (stx? internal-context)
|
||||
`(#%decode-syntax
|
||||
,(decompile-stx (stx-content internal-context) stx-ht))
|
||||
internal-context))
|
||||
(quote bindings ,(for/hash ([(phase ht) (in-hash binding-names)])
|
||||
(values phase
|
||||
(for/hash ([(sym id) (in-hash ht)])
|
||||
(values sym
|
||||
(if (eq? id #t)
|
||||
#t
|
||||
`(#%decode-syntax
|
||||
,(decompile-stx (stx-content id) stx-ht))))))))
|
||||
(quote language-info ,lang-info)
|
||||
,@(if (null? flags) '() (list `(quote ,flags)))
|
||||
,@(let ([l (apply
|
||||
append
|
||||
(for/list ([req (in-list requires)]
|
||||
#:when (pair? (cdr req)))
|
||||
(define l (for/list ([mpi (in-list (cdr req))])
|
||||
(define p (mpi->string mpi))
|
||||
(if (path? p)
|
||||
(let ([d (current-load-relative-directory)])
|
||||
(path->string (if d
|
||||
(find-relative-path (simplify-path d #t)
|
||||
(simplify-path p #f)
|
||||
#:more-than-root? #t)
|
||||
p)))
|
||||
p)))
|
||||
(if (eq? 0 (car req))
|
||||
l
|
||||
`((,@(case (car req)
|
||||
[(#f) `(for-label)]
|
||||
[(1) `(for-syntax)]
|
||||
[else `(for-meta ,(car req))])
|
||||
,@l)))))])
|
||||
(if (null? l)
|
||||
null
|
||||
`((require ,@l))))
|
||||
(provide ,@(apply
|
||||
append
|
||||
(for/list ([p (in-list provides)])
|
||||
(define phase (car p))
|
||||
(define l
|
||||
(for/list ([pv (in-list (append (cadr p) (caddr p)))])
|
||||
(match pv
|
||||
[(struct provided (name src src-name nom-src src-phase protected?))
|
||||
(define n (if (eq? name src-name)
|
||||
name
|
||||
`(rename-out [,src-name ,name])))
|
||||
(if protected?
|
||||
`(protect-out ,n)
|
||||
n)])))
|
||||
(if (or (null? l) (eq? phase 0))
|
||||
l
|
||||
`((,@(case phase
|
||||
[(#f) `(for-label)]
|
||||
[(1) `(for-syntax)]
|
||||
[else `(for-meta ,phase)])
|
||||
,@l))))))
|
||||
,@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)
|
||||
(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)
|
||||
,@(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 'module)]
|
||||
[(struct def-values (ids rhs))
|
||||
`(define-values ,(map (lambda (tl)
|
||||
(match tl
|
||||
[(struct toplevel (depth pos const? set-const?))
|
||||
(list-ref/protect (glob-desc-vars globs) pos 'def-vals)]))
|
||||
ids)
|
||||
,(if (inline-variant? rhs)
|
||||
`(begin
|
||||
,(list 'quote '%%inline-variant%%)
|
||||
,(decompile-expr (inline-variant-inline rhs) globs stack closed)
|
||||
,(decompile-expr (inline-variant-direct rhs) globs stack closed))
|
||||
(decompile-expr rhs globs stack closed)))]
|
||||
[(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 seq-for-syntax (exprs prefix max-let-depth dummy))
|
||||
`(begin-for-syntax
|
||||
,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
|
||||
`(let ()
|
||||
,@defns
|
||||
,@(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))
|
||||
forms))]
|
||||
[(struct splice (forms))
|
||||
`(begin ,@(map (lambda (form)
|
||||
(decompile-form form globs stack closed stx-ht))
|
||||
forms))]
|
||||
[(struct req (reqs dummy))
|
||||
`(#%require . (#%decode-syntax ,reqs))]
|
||||
[else
|
||||
(decompile-expr form globs stack closed)]))
|
||||
|
||||
(define (extract-name name)
|
||||
(if (symbol? name)
|
||||
(gensym name)
|
||||
(if (vector? name)
|
||||
(gensym (vector-ref name 0))
|
||||
#f)))
|
||||
|
||||
(define (extract-id expr)
|
||||
(match expr
|
||||
[(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body))
|
||||
(extract-name name)]
|
||||
[(struct case-lam (name lams))
|
||||
(extract-name name)]
|
||||
[(struct closure (lam gen-id))
|
||||
(extract-id lam)]
|
||||
[else #f]))
|
||||
|
||||
(define (extract-ids! body ids)
|
||||
(match body
|
||||
[(struct let-rec (procs body))
|
||||
(for ([proc (in-list procs)]
|
||||
[delta (in-naturals)])
|
||||
(when (< -1 delta (vector-length ids))
|
||||
(vector-set! ids delta (extract-id proc))))
|
||||
(extract-ids! body ids)]
|
||||
[(struct install-value (val-count pos boxes? rhs body))
|
||||
(extract-ids! body ids)]
|
||||
[(struct boxenv (pos body))
|
||||
(extract-ids! body ids)]
|
||||
[else #f]))
|
||||
|
||||
(define (decompile-tl expr globs stack closed no-check?)
|
||||
(match expr
|
||||
[(struct toplevel (depth pos const? ready?))
|
||||
(let ([id (list-ref/protect (glob-desc-vars globs) pos 'toplevel)])
|
||||
(cond
|
||||
[no-check? id]
|
||||
[(and (not const?) (not ready?))
|
||||
`(#%checked ,id)]
|
||||
#;[(and const? ready?) `(#%const ,id)]
|
||||
#;[const? `(#%iconst ,id)]
|
||||
[else id]))]))
|
||||
|
||||
(define (decompile-expr expr globs stack closed)
|
||||
(match expr
|
||||
[(struct toplevel (depth pos const? ready?))
|
||||
(decompile-tl expr globs stack closed #f)]
|
||||
[(struct varref (tl dummy))
|
||||
`(#%variable-reference ,(if (eq? tl #t)
|
||||
'<constant-local>
|
||||
(decompile-tl tl globs stack closed #t)))]
|
||||
[(struct topsyntax (depth pos midpt))
|
||||
(list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)]
|
||||
[(struct primval (id))
|
||||
(hash-ref primitive-table id (lambda () (error "unknown primitive: " id)))]
|
||||
[(struct assign (id rhs undef-ok?))
|
||||
`(set! ,(decompile-expr id globs stack closed)
|
||||
,(decompile-expr rhs globs stack closed))]
|
||||
[(struct localref (unbox? offset clear? other-clears? type))
|
||||
(let ([id (list-ref/protect stack offset 'localref)])
|
||||
(let ([e (if unbox?
|
||||
`(#%unbox ,id)
|
||||
id)])
|
||||
(if clear?
|
||||
`(#%sfs-clear ,e)
|
||||
e)))]
|
||||
[(? lam?)
|
||||
`(lambda . ,(decompile-lam expr globs stack closed))]
|
||||
[(struct case-lam (name lams))
|
||||
`(case-lambda
|
||||
,@(map (lambda (lam)
|
||||
(decompile-lam lam globs stack closed))
|
||||
lams))]
|
||||
[(struct let-one (rhs body type unused?))
|
||||
(let ([id (or (extract-id rhs)
|
||||
(gensym (or type (if unused? 'unused 'local))))])
|
||||
`(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)])
|
||||
,(decompile-expr body globs (cons id stack) closed)))]
|
||||
[(struct let-void (count boxes? body))
|
||||
(let ([ids (make-vector count #f)])
|
||||
(extract-ids! body ids)
|
||||
(let ([vars (for/list ([i (in-range count)]
|
||||
[id (in-vector ids)])
|
||||
(or id (gensym (if boxes? 'localvb 'localv))))])
|
||||
`(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)])
|
||||
vars)
|
||||
,(decompile-expr body globs (append vars stack) closed))))]
|
||||
[(struct let-rec (procs body))
|
||||
`(begin
|
||||
(#%set!-rec-values ,(for/list ([p (in-list procs)]
|
||||
[i (in-naturals)])
|
||||
(list-ref/protect stack i 'let-rec))
|
||||
,@(map (lambda (proc)
|
||||
(decompile-expr proc globs stack closed))
|
||||
procs))
|
||||
,(decompile-expr body globs stack closed))]
|
||||
[(struct install-value (count pos boxes? rhs body))
|
||||
`(begin
|
||||
(,(if boxes? '#%set-boxes! 'set!-values)
|
||||
,(for/list ([i (in-range count)])
|
||||
(list-ref/protect stack (+ i pos) 'install-value))
|
||||
,(decompile-expr rhs globs stack closed))
|
||||
,(decompile-expr body globs stack closed))]
|
||||
[(struct boxenv (pos body))
|
||||
(let ([id (list-ref/protect stack pos 'boxenv)])
|
||||
`(begin
|
||||
(set! ,id (#%box ,id))
|
||||
,(decompile-expr body globs stack closed)))]
|
||||
[(struct branch (test then else))
|
||||
`(if ,(decompile-expr test globs stack closed)
|
||||
,(decompile-expr then globs stack closed)
|
||||
,(decompile-expr else globs stack closed))]
|
||||
[(struct application (rator rands))
|
||||
(let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
|
||||
stack)])
|
||||
(annotate-unboxed
|
||||
rands
|
||||
(annotate-inline
|
||||
`(,(decompile-expr rator globs stack closed)
|
||||
,@(map (lambda (rand)
|
||||
(decompile-expr rand globs stack closed))
|
||||
rands)))))]
|
||||
[(struct apply-values (proc args-expr))
|
||||
`(#%apply-values ,(decompile-expr proc globs stack closed)
|
||||
,(decompile-expr args-expr globs stack closed))]
|
||||
[(struct with-immed-mark (key-expr val-expr body-expr))
|
||||
(let ([id (gensym 'cmval)])
|
||||
`(#%call-with-immediate-continuation-mark
|
||||
,(decompile-expr key-expr globs stack closed)
|
||||
(lambda (,id) ,(decompile-expr body-expr globs (cons id stack) closed))
|
||||
,(decompile-expr val-expr globs stack closed)))]
|
||||
[(struct seq (exprs))
|
||||
`(begin ,@(for/list ([expr (in-list exprs)])
|
||||
(decompile-expr expr globs stack closed)))]
|
||||
[(struct beg0 (exprs))
|
||||
`(begin0
|
||||
,@(for/list ([expr (in-list exprs)])
|
||||
(decompile-expr expr globs stack closed))
|
||||
;; Make sure a single expression doesn't look like tail position:
|
||||
,@(if (null? (cdr exprs)) (list #f) null))]
|
||||
[(struct with-cont-mark (key val body))
|
||||
`(with-continuation-mark
|
||||
,(decompile-expr key globs stack closed)
|
||||
,(decompile-expr val globs stack closed)
|
||||
,(decompile-expr body globs stack closed))]
|
||||
[(struct closure (lam gen-id))
|
||||
(if (hash-ref closed gen-id #f)
|
||||
gen-id
|
||||
(begin
|
||||
(hash-set! closed gen-id #t)
|
||||
`(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))]
|
||||
[else `(quote ,expr)]))
|
||||
|
||||
(define (decompile-lam expr globs stack closed)
|
||||
(match expr
|
||||
[(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)]
|
||||
[(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body))
|
||||
(let ([vars (for/list ([i (in-range num-params)]
|
||||
[type (in-list arg-types)])
|
||||
(gensym (format "~a~a-"
|
||||
(case type
|
||||
[(ref) "argbox"]
|
||||
[(val) "arg"]
|
||||
[else (format "arg~a" type)])
|
||||
i)))]
|
||||
[rest-vars (if rest? (list (gensym 'rest)) null)]
|
||||
[captures (map (lambda (v)
|
||||
(list-ref/protect stack v 'lam))
|
||||
(vector->list closure-map))])
|
||||
`((,@vars . ,(if rest?
|
||||
(car rest-vars)
|
||||
null))
|
||||
,@(if (and name (not (null? name)))
|
||||
`(',name)
|
||||
null)
|
||||
,@(if (null? flags) null `('(flags: ,@flags)))
|
||||
,@(if (null? captures)
|
||||
null
|
||||
`('(captures: ,@(map (lambda (c t)
|
||||
(if t
|
||||
`(,t ,c)
|
||||
c))
|
||||
captures
|
||||
closure-types)
|
||||
,@(if (not tl-map)
|
||||
'()
|
||||
(list
|
||||
(for/list ([pos (in-list (sort (set->list tl-map) <))])
|
||||
(define tl-pos
|
||||
(cond
|
||||
[(or (pos . < . (glob-desc-num-tls globs))
|
||||
(zero? (glob-desc-num-stxs globs)))
|
||||
pos]
|
||||
[(= pos (glob-desc-num-tls globs))
|
||||
'stx]
|
||||
[else
|
||||
(+ pos (glob-desc-num-stxs globs))]))
|
||||
(if (eq? tl-pos 'stx)
|
||||
'#%syntax
|
||||
(list-ref/protect (glob-desc-vars globs)
|
||||
tl-pos
|
||||
'lam))))))))
|
||||
,(decompile-expr body globs
|
||||
(append captures
|
||||
(append vars rest-vars))
|
||||
closed)))]))
|
||||
|
||||
(define (annotate-inline a)
|
||||
a)
|
||||
|
||||
(define (annotate-unboxed args a)
|
||||
a)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
#;
|
||||
(begin
|
||||
(require scheme/pretty)
|
||||
(define (try e)
|
||||
(pretty-print
|
||||
(decompile
|
||||
(zo-parse (let-values ([(in out) (make-pipe)])
|
||||
(write (parameterize ([current-namespace (make-base-namespace)])
|
||||
(compile e))
|
||||
out)
|
||||
(close-output-port out)
|
||||
in)))))
|
||||
(pretty-print
|
||||
(decompile
|
||||
(zo-parse (open-input-file "/home/mflatt/proj/plt/collects/tests/mzscheme/benchmarks/common/sboyer_ss.zo"))))
|
||||
#;
|
||||
(try '(lambda (q . more)
|
||||
(letrec ([f (lambda (x) f)])
|
||||
(lambda (g) f)))))
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/match racket/contract compiler/zo-parse)
|
||||
|
||||
(define (alpha-vary-ctop top)
|
||||
(match top
|
||||
[(struct compilation-top (max-let-depth binding-namess prefix form))
|
||||
(make-compilation-top max-let-depth binding-namess (alpha-vary-prefix prefix) form)]))
|
||||
(define (alpha-vary-prefix p)
|
||||
(struct-copy prefix p
|
||||
[toplevels
|
||||
(map (match-lambda
|
||||
[(and sym (? symbol?))
|
||||
(gensym sym)]
|
||||
[other
|
||||
other])
|
||||
(prefix-toplevels p))]))
|
||||
|
||||
(provide/contract
|
||||
[alpha-vary-ctop (compilation-top? . -> . compilation-top?)])
|
||||
|
|
@ -1,63 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
#|
|
||||
Here's the idea:
|
||||
|
||||
- Take a module's bytecode
|
||||
- Recursively get all the bytecode for modules that the target requires
|
||||
- After reading it, prune everything that isn't at phase 0 (the runtime phase)
|
||||
|
||||
- Now that we have all the modules, the next step is to merge them into a single
|
||||
module
|
||||
-- Although actually we collapse them into the top-level, not a module
|
||||
- To do that, we iterate through all the modules doing two things as we go:
|
||||
-- Incrementing all the global variable references by all the references in all
|
||||
the modules
|
||||
--- So if A has 5, then B's start at index 5 and so on
|
||||
-- Replacing module variable references with the actual global variables
|
||||
corresponding to those variables
|
||||
--- So if A's variable 'x' is in global slot 4, then if B refers to it, it
|
||||
directly uses slot 4, rather than a module-variable slot
|
||||
|
||||
- At that point we have all the module code in a single top-level, but many
|
||||
toplevels won't be used because a library function isn't really used
|
||||
- So, we do a "garbage collection" on elements of the prefix
|
||||
- First, we create a dependency graph of all toplevels and the initial scope
|
||||
- Then, we do a DFS on the initial scope and keep all those toplevels, throwing
|
||||
away the construction of everything else
|
||||
[XXX: This may be broken because of side-effects.]
|
||||
|
||||
- Now we have a small amount code, but because we want to go back to source,
|
||||
we need to fix it up a bit; because different modules may've used the same
|
||||
names
|
||||
- So, we do alpha-renaming, but it's easy because names are only used in the
|
||||
compilation-top prefix structure
|
||||
|
||||
[TODO]
|
||||
|
||||
- Next, we decompile
|
||||
- Then, it will pay to do dead code elimination and inlining, etc.
|
||||
|#
|
||||
|
||||
(require racket/cmdline
|
||||
racket/set
|
||||
raco/command-name
|
||||
"main.rkt")
|
||||
|
||||
|
||||
(let ([output-file (make-parameter #f)])
|
||||
(command-line #:program (short-program+command-name)
|
||||
#:multi
|
||||
[("-e" "--exclude-modules") path "Exclude <path> from flattening"
|
||||
(current-excluded-modules (set-add (current-excluded-modules) path))]
|
||||
#:once-each
|
||||
[("-o") dest-filename "Write output as <dest-filename>"
|
||||
(output-file (string->path dest-filename))]
|
||||
[("-g" "--garbage-collect") "Garbage-collect final module (unsound)"
|
||||
(garbage-collect-toplevels-enabled #t)]
|
||||
[("-r" "--recompile") "Recompile final module to re-run optimizations"
|
||||
(recompile-enabled #t)]
|
||||
#:args (filename)
|
||||
(demodularize filename (output-file))))
|
||||
|
||||
(module test racket/base)
|
||||
|
|
@ -1,288 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/match
|
||||
racket/list
|
||||
racket/dict
|
||||
racket/contract
|
||||
compiler/zo-parse
|
||||
"util.rkt")
|
||||
|
||||
; XXX Use efficient set structure
|
||||
(define (gc-toplevels top)
|
||||
(match top
|
||||
[(struct compilation-top (max-let-depth binding-namess top-prefix form))
|
||||
(define lift-start
|
||||
(prefix-lift-start top-prefix))
|
||||
(define max-depgraph-index
|
||||
(+ (prefix-num-lifts top-prefix)
|
||||
lift-start))
|
||||
(define top-node max-depgraph-index)
|
||||
(define DEP-GRAPH (make-vector (add1 top-node) (make-refs empty empty)))
|
||||
(define build-graph! (make-build-graph! DEP-GRAPH))
|
||||
(define _void (build-graph! (list top-node) form))
|
||||
(define-values (used-tls stxs) (graph-dfs DEP-GRAPH top-node))
|
||||
(define ordered-used-tls (sort (rest used-tls) <=)) ; This rest drops off the top-node
|
||||
(define ordered-stxs (sort stxs <=))
|
||||
(define (lift? i) (lift-start . <= . i))
|
||||
(define-values (lifts normal-tls) (partition lift? ordered-used-tls))
|
||||
(define new-prefix
|
||||
(make-prefix
|
||||
(length lifts)
|
||||
(for/list ([i normal-tls])
|
||||
(list-ref (prefix-toplevels top-prefix) i))
|
||||
(for/list ([i ordered-stxs])
|
||||
(list-ref (prefix-stxs top-prefix) i))))
|
||||
(define new-lift-start
|
||||
(prefix-lift-start new-prefix))
|
||||
; XXX This probably breaks max-let-depth
|
||||
(define new-form
|
||||
((gc-toplevels-form
|
||||
(lambda (pos) (index<=? pos ordered-used-tls))
|
||||
(lambda (pos)
|
||||
(if (lift? pos)
|
||||
(+ new-lift-start (index<=? pos lifts))
|
||||
(index<=? pos normal-tls)))
|
||||
(lambda (stx-pos)
|
||||
(index<=? stx-pos ordered-stxs))
|
||||
(prefix-syntax-start new-prefix))
|
||||
form))
|
||||
(log-debug (format "Total TLS: ~S" (length normal-tls)))
|
||||
(log-debug (format "Used TLS: ~S" normal-tls))
|
||||
(log-debug (format "Total lifts: ~S" (length lifts)))
|
||||
(log-debug (format "Used lifts: ~S" lifts))
|
||||
(log-debug (format "Total stxs: ~S" (length stxs)))
|
||||
(log-debug (format "Used stxs: ~S" ordered-stxs))
|
||||
(make-compilation-top
|
||||
max-let-depth
|
||||
#hash()
|
||||
new-prefix
|
||||
new-form)]))
|
||||
|
||||
(define-struct refs (tl stx) #:transparent)
|
||||
|
||||
(define (make-build-graph! DEP-GRAPH)
|
||||
(define (build-graph!* form lhs)
|
||||
(match form
|
||||
[(struct def-values (ids rhs))
|
||||
(define new-lhs (map toplevel-pos ids))
|
||||
; If we require one, we should require all, so make them reference each other
|
||||
(for-each (lambda (tl) (build-graph! new-lhs tl)) ids)
|
||||
(build-graph! new-lhs rhs)]
|
||||
[(? def-syntaxes?)
|
||||
(error 'build-graph "Doesn't handle syntax")]
|
||||
[(? seq-for-syntax?)
|
||||
(error 'build-graph "Doesn't handle syntax")]
|
||||
[(struct inline-variant (direct inline))
|
||||
(build-graph! lhs direct)]
|
||||
[(struct req (reqs dummy))
|
||||
(build-graph! lhs dummy)]
|
||||
[(? mod?)
|
||||
(error 'build-graph "Doesn't handle modules")]
|
||||
[(struct seq (forms))
|
||||
(for-each (lambda (f) (build-graph! lhs f)) forms)]
|
||||
[(struct splice (forms))
|
||||
(for-each (lambda (f) (build-graph! lhs f)) forms)]
|
||||
[(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body)))
|
||||
(build-graph! lhs body)]
|
||||
[(and c (struct closure (code gen-id)))
|
||||
(build-graph! lhs code)]
|
||||
[(and cl (struct case-lam (name clauses)))
|
||||
(for-each (lambda (l) (build-graph! lhs l))
|
||||
clauses)]
|
||||
[(struct let-one (rhs body flonum? unused?))
|
||||
(build-graph! lhs rhs)
|
||||
(build-graph! lhs body)]
|
||||
[(and f (struct let-void (count boxes? body)))
|
||||
(build-graph! lhs body)]
|
||||
[(and f (struct install-value (_ _ _ rhs body)))
|
||||
(build-graph! lhs rhs)
|
||||
(build-graph! lhs body)]
|
||||
[(struct let-rec (procs body))
|
||||
(for-each (lambda (l) (build-graph! lhs l)) procs)
|
||||
(build-graph! lhs body)]
|
||||
[(and f (struct boxenv (_ body)))
|
||||
(build-graph! lhs body)]
|
||||
[(and f (struct toplevel (_ pos _ _)))
|
||||
(for-each (lambda (lhs)
|
||||
(dict-update! DEP-GRAPH lhs
|
||||
(match-lambda
|
||||
[(struct refs (tls stxs))
|
||||
(make-refs (list* pos tls) stxs)])))
|
||||
lhs)]
|
||||
[(and f (struct topsyntax (_ pos _)))
|
||||
(for-each (lambda (lhs)
|
||||
(dict-update! DEP-GRAPH lhs
|
||||
(match-lambda
|
||||
[(struct refs (tls stxs))
|
||||
(make-refs tls (list* pos stxs))])))
|
||||
lhs)]
|
||||
[(struct application (rator rands))
|
||||
(for-each (lambda (f) (build-graph! lhs f))
|
||||
(list* rator rands))]
|
||||
[(struct branch (test then else))
|
||||
(for-each (lambda (f) (build-graph! lhs f))
|
||||
(list test then else))]
|
||||
[(struct with-cont-mark (key val body))
|
||||
(for-each (lambda (f) (build-graph! lhs f))
|
||||
(list key val body))]
|
||||
[(struct with-immed-mark (key val body))
|
||||
(for-each (lambda (f) (build-graph! lhs f))
|
||||
(list key val body))]
|
||||
[(struct beg0 (seq))
|
||||
(for-each (lambda (f) (build-graph! lhs f))
|
||||
seq)]
|
||||
[(struct varref (tl dummy))
|
||||
(build-graph! lhs tl)
|
||||
(build-graph! lhs dummy)]
|
||||
[(and f (struct assign (id rhs undef-ok?)))
|
||||
(build-graph! lhs id)
|
||||
(build-graph! lhs rhs)]
|
||||
[(struct apply-values (proc args-expr))
|
||||
(build-graph! lhs proc)
|
||||
(build-graph! lhs args-expr)]
|
||||
[(and f (struct primval (id)))
|
||||
(void)]
|
||||
[(and f (struct localref (unbox? pos clear? other-clears? type)))
|
||||
(void)]
|
||||
[(and v (not (? form?)))
|
||||
(void)]))
|
||||
(define-values (first-build-graph!** build-graph!**)
|
||||
(build-form-memo build-graph!* #:void? #t))
|
||||
(define (build-graph! lhs form) (first-build-graph!** form lhs))
|
||||
build-graph!)
|
||||
|
||||
(define (graph-dfs g start-node)
|
||||
(define visited? (make-hasheq))
|
||||
(define (visit-tl n tls stxs)
|
||||
(if (hash-has-key? visited? n)
|
||||
(values tls stxs)
|
||||
(match (dict-ref g n)
|
||||
[(struct refs (n-tls n-stxs))
|
||||
(hash-set! visited? n #t)
|
||||
(define-values (new-tls1 new-stxs1)
|
||||
(for/fold ([new-tls tls]
|
||||
[new-stxs stxs])
|
||||
([tl (in-list n-tls)])
|
||||
(visit-tl tl new-tls new-stxs)))
|
||||
(define new-stxs2
|
||||
(for/fold ([new-stxs new-stxs1])
|
||||
([stx (in-list n-stxs)])
|
||||
(define this-stx (visit-stx stx))
|
||||
(if this-stx
|
||||
(list* this-stx new-stxs)
|
||||
new-stxs)))
|
||||
(values (list* n new-tls1)
|
||||
new-stxs2)])))
|
||||
(define stx-visited? (make-hasheq))
|
||||
(define (visit-stx n)
|
||||
(if (hash-has-key? stx-visited? n)
|
||||
#f
|
||||
(begin (hash-set! stx-visited? n #t)
|
||||
n)))
|
||||
(visit-tl start-node empty empty))
|
||||
|
||||
; index<=? : number? (listof number?) -> (or/c number? false/c)
|
||||
; returns the index of n in l and assumes that l is sorted by <=
|
||||
(define (index<=? n l)
|
||||
(match l
|
||||
[(list) #f]
|
||||
[(list-rest f l)
|
||||
(cond
|
||||
[(= n f)
|
||||
0]
|
||||
[(< n f)
|
||||
#f]
|
||||
[else
|
||||
(let ([rec (index<=? n l)])
|
||||
(if rec (add1 rec) rec))])]))
|
||||
|
||||
(define (identity x) x)
|
||||
(define (gc-toplevels-form keep? update-tl update-ts new-ts-midpt)
|
||||
(define (inner-update form)
|
||||
(match form
|
||||
[(struct def-values (ids rhs))
|
||||
(if (ormap (compose keep? toplevel-pos) ids)
|
||||
(make-def-values (map update ids)
|
||||
(update rhs))
|
||||
#f)]
|
||||
[(? def-syntaxes?)
|
||||
(error 'gc-tls "Doesn't handle syntax")]
|
||||
[(? seq-for-syntax?)
|
||||
(error 'gc-tls "Doesn't handle syntax")]
|
||||
[(struct req (reqs dummy))
|
||||
(make-req reqs (update dummy))]
|
||||
[(? mod?)
|
||||
(error 'gc-tls "Doesn't handle modules")]
|
||||
[(struct seq (forms))
|
||||
(make-seq (filter identity (map update forms)))]
|
||||
[(struct splice (forms))
|
||||
(make-splice (filter identity (map update forms)))]
|
||||
[(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body)))
|
||||
(struct-copy lam l
|
||||
[toplevel-map #f] ; consevrative
|
||||
[body (update body)])]
|
||||
[(and c (struct closure (code gen-id)))
|
||||
(struct-copy closure c
|
||||
[code (update code)])]
|
||||
[(and cl (struct case-lam (name clauses)))
|
||||
(struct-copy case-lam cl
|
||||
[clauses (map update clauses)])]
|
||||
[(struct let-one (rhs body type unused?))
|
||||
(make-let-one (update rhs) (update body) type unused?)]
|
||||
[(and f (struct let-void (count boxes? body)))
|
||||
(struct-copy let-void f
|
||||
[body (update body)])]
|
||||
[(and f (struct install-value (_ _ _ rhs body)))
|
||||
(struct-copy install-value f
|
||||
[rhs (update rhs)]
|
||||
[body (update body)])]
|
||||
[(struct let-rec (procs body))
|
||||
(make-let-rec (map update procs) (update body))]
|
||||
[(and f (struct boxenv (_ body)))
|
||||
(struct-copy boxenv f [body (update body)])]
|
||||
[(and f (struct toplevel (_ pos _ _)))
|
||||
(struct-copy toplevel f
|
||||
[pos (update-tl pos)])]
|
||||
[(and f (struct topsyntax (_ pos _)))
|
||||
(struct-copy topsyntax f
|
||||
[pos (update-ts pos)]
|
||||
[midpt new-ts-midpt])]
|
||||
[(struct application (rator rands))
|
||||
(make-application
|
||||
(update rator)
|
||||
(map update rands))]
|
||||
[(struct branch (test then else))
|
||||
(make-branch
|
||||
(update test)
|
||||
(update then)
|
||||
(update else))]
|
||||
[(struct with-cont-mark (key val body))
|
||||
(make-with-cont-mark
|
||||
(update key)
|
||||
(update val)
|
||||
(update body))]
|
||||
[(struct beg0 (seq))
|
||||
(make-beg0 (map update seq))]
|
||||
[(struct varref (tl dummy))
|
||||
(make-varref (update tl) (update dummy))]
|
||||
[(and f (struct assign (id rhs undef-ok?)))
|
||||
(struct-copy assign f
|
||||
[id (update id)]
|
||||
[rhs (update rhs)])]
|
||||
[(struct apply-values (proc args-expr))
|
||||
(make-apply-values
|
||||
(update proc)
|
||||
(update args-expr))]
|
||||
[(and f (struct primval (id)))
|
||||
f]
|
||||
[(and f (struct localref (unbox? pos clear? other-clears? type)))
|
||||
f]
|
||||
[(and v (not (? form?)))
|
||||
v]
|
||||
))
|
||||
(define-values (first-update update)
|
||||
(build-form-memo inner-update))
|
||||
first-update)
|
||||
|
||||
(provide/contract
|
||||
[gc-toplevels (compilation-top? . -> . compilation-top?)])
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define test-responsibles '((all jay)))
|
||||
|
|
@ -1,91 +0,0 @@
|
|||
#lang racket/base
|
||||
(require compiler/cm
|
||||
compiler/zo-marshal
|
||||
"alpha.rkt"
|
||||
"gc-toplevels.rkt"
|
||||
"merge.rkt"
|
||||
"module.rkt"
|
||||
"mpi.rkt"
|
||||
"nodep.rkt"
|
||||
"replace-modidx.rkt")
|
||||
|
||||
(provide current-excluded-modules
|
||||
garbage-collect-toplevels-enabled
|
||||
recompile-enabled
|
||||
demodularize)
|
||||
|
||||
(define garbage-collect-toplevels-enabled (make-parameter #f))
|
||||
(define recompile-enabled (make-parameter #f))
|
||||
|
||||
(define logger (make-logger 'demodularizer (current-logger)))
|
||||
|
||||
(define (demodularize file-to-batch [output-file #f])
|
||||
(parameterize ([current-logger logger])
|
||||
(define-values (base name must-be-dir?) (split-path file-to-batch))
|
||||
(when must-be-dir?
|
||||
(error 'demodularize "Cannot run on directory: ~a" file-to-batch))
|
||||
(unless (file-exists? file-to-batch)
|
||||
(error 'demodularize "File does not exist: ~a" file-to-batch))
|
||||
|
||||
;; Compile
|
||||
(log-info "Compiling module")
|
||||
(parameterize ([current-namespace (make-base-empty-namespace)])
|
||||
(managed-compile-zo file-to-batch))
|
||||
|
||||
(define merged-zo-path
|
||||
(or output-file
|
||||
(path-add-suffix file-to-batch #"_merged.zo")))
|
||||
|
||||
;; Transformations
|
||||
(define path-cache (make-hasheq))
|
||||
|
||||
(log-info "Removing dependencies")
|
||||
(define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite)
|
||||
(parameterize ([MODULE-PATHS path-cache])
|
||||
(nodep-file file-to-batch)))
|
||||
|
||||
(log-info "Merging modules")
|
||||
(define batch-merge
|
||||
(parameterize ([MODULE-PATHS path-cache])
|
||||
(merge-compilation-top get-modvar-rewrite batch-nodep)))
|
||||
|
||||
(define batch-gcd
|
||||
(if (garbage-collect-toplevels-enabled)
|
||||
(begin
|
||||
(log-info "GC-ing top-levels")
|
||||
(gc-toplevels batch-merge))
|
||||
batch-merge))
|
||||
|
||||
(log-info "Alpha-varying top-levels")
|
||||
(define batch-alpha
|
||||
(alpha-vary-ctop batch-gcd))
|
||||
|
||||
(log-info "Replacing self-modidx")
|
||||
(define batch-replace-modidx
|
||||
(replace-modidx batch-alpha top-self-modidx))
|
||||
|
||||
(define batch-modname
|
||||
(string->symbol (regexp-replace #rx"\\.zo$" (path->string merged-zo-path) "")))
|
||||
(log-info (format "Modularizing into ~a" batch-modname))
|
||||
(define batch-mod
|
||||
(wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx))
|
||||
|
||||
(log-info "Writing merged zo")
|
||||
(void
|
||||
(with-output-to-file
|
||||
merged-zo-path
|
||||
(lambda ()
|
||||
(zo-marshal-to batch-mod (current-output-port)))
|
||||
#:exists 'replace))
|
||||
|
||||
(void
|
||||
(when (recompile-enabled)
|
||||
(define recomp
|
||||
(compiled-expression-recompile
|
||||
(parameterize ([read-accept-compiled #t])
|
||||
(call-with-input-file merged-zo-path read))))
|
||||
(call-with-output-file merged-zo-path
|
||||
(lambda (out)
|
||||
(write recomp out))
|
||||
#:exists 'replace)))))
|
||||
|
||||
|
|
@ -1,229 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/list
|
||||
racket/match
|
||||
racket/contract
|
||||
compiler/zo-parse
|
||||
"util.rkt"
|
||||
"mpi.rkt"
|
||||
"nodep.rkt"
|
||||
"update-toplevels.rkt")
|
||||
|
||||
(define MODULE-TOPLEVEL-OFFSETS (make-hasheq))
|
||||
|
||||
(define current-get-modvar-rewrite (make-parameter #f))
|
||||
(define (merge-compilation-top get-modvar-rewrite top)
|
||||
(parameterize ([current-get-modvar-rewrite get-modvar-rewrite])
|
||||
(match top
|
||||
[(struct compilation-top (max-let-depth binding-namess prefix form))
|
||||
(define-values (new-max-let-depth new-prefix gen-new-forms)
|
||||
(merge-form max-let-depth prefix form))
|
||||
(define total-tls (length (prefix-toplevels new-prefix)))
|
||||
(define total-stxs (length (prefix-stxs new-prefix)))
|
||||
(define total-lifts (prefix-num-lifts new-prefix))
|
||||
(log-debug (format "max-let-depth ~S to ~S" max-let-depth new-max-let-depth))
|
||||
(log-debug (format "total toplevels ~S" total-tls))
|
||||
(log-debug (format "total stxs ~S" total-stxs))
|
||||
(log-debug (format "num-lifts ~S" total-lifts))
|
||||
(for ([i (in-naturals)]
|
||||
[p (in-list (prefix-toplevels new-prefix))])
|
||||
(log-debug (format "new-prefix tls\t~v ~v" i p)))
|
||||
(make-compilation-top
|
||||
new-max-let-depth #hash() new-prefix
|
||||
(make-splice (gen-new-forms new-prefix)))]
|
||||
[else (error 'merge "unrecognized: ~e" top)])))
|
||||
|
||||
(define (merge-forms max-let-depth prefix forms)
|
||||
(if (empty? forms)
|
||||
(values max-let-depth prefix (lambda _ empty))
|
||||
(let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))]
|
||||
[(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))])
|
||||
(values rmax-let-depth
|
||||
rprefix
|
||||
(lambda args
|
||||
(append (apply gen-fform args)
|
||||
(apply gen-rforms args)))))))
|
||||
|
||||
(define (merge-form max-let-depth prefix form)
|
||||
(match form
|
||||
[(? mod?)
|
||||
(merge-module max-let-depth prefix form)]
|
||||
[(struct seq (forms))
|
||||
(merge-forms max-let-depth prefix forms)]
|
||||
[(struct splice (forms))
|
||||
(merge-forms max-let-depth prefix forms)]
|
||||
[else
|
||||
(values max-let-depth prefix (lambda _ (list form)))]))
|
||||
|
||||
(define (index-of v l)
|
||||
(for/or ([e (in-list l)]
|
||||
[i (in-naturals)]
|
||||
#:when (eq? e v))
|
||||
i))
|
||||
|
||||
(define (merge-prefix root-prefix mod-prefix)
|
||||
(match-define (struct prefix (root-num-lifts root-toplevels root-stxs root-src-insp-desc)) root-prefix)
|
||||
(match-define (struct prefix (mod-num-lifts mod-toplevels mod-stxs src-insp-desc)) mod-prefix)
|
||||
(make-prefix (+ root-num-lifts mod-num-lifts)
|
||||
(append root-toplevels mod-toplevels)
|
||||
(append root-stxs mod-stxs)
|
||||
root-src-insp-desc))
|
||||
|
||||
(struct toplevel-offset-rewriter (rewrite-fun meta) #:transparent)
|
||||
|
||||
(define (compute-new-modvar mv rw)
|
||||
(match mv
|
||||
[(struct module-variable (modidx sym pos phase constantness))
|
||||
(match rw
|
||||
[(struct modvar-rewrite (self-modidx provide->toplevel))
|
||||
(log-debug (format "Rewriting ~a@~a of ~S" sym pos (mpi->path* modidx)))
|
||||
(define tl (provide->toplevel sym pos))
|
||||
(log-debug (format "Rewriting ~a@~a of ~S to ~S" sym pos (mpi->path* modidx) tl))
|
||||
(match-define (toplevel-offset-rewriter rewrite-fun meta)
|
||||
(hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx
|
||||
(lambda ()
|
||||
(error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx))))
|
||||
(log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S" sym pos (mpi->path* modidx) tl meta))
|
||||
(define res (rewrite-fun tl))
|
||||
(log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S and got ~S"
|
||||
sym pos (mpi->path* modidx) tl meta res))
|
||||
res])]))
|
||||
|
||||
(define (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels)
|
||||
(define-values
|
||||
(i new-toplevels remap)
|
||||
(for/fold ([i 0]
|
||||
[new-toplevels empty]
|
||||
[remap empty])
|
||||
([tl (in-list mod-toplevels)]
|
||||
[idx (in-naturals)])
|
||||
(log-debug (format "[~S] mod-prefix tls\t~v ~v"
|
||||
name idx tl))
|
||||
(match tl
|
||||
[(and mv (struct module-variable (modidx sym pos phase constantness)))
|
||||
(define rw ((current-get-modvar-rewrite) modidx))
|
||||
;; XXX We probably don't need to deal with #f phase
|
||||
(unless (or (not phase) (zero? phase))
|
||||
(error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv))
|
||||
(cond
|
||||
; Primitive module like #%paramz
|
||||
[(symbol? rw)
|
||||
(log-debug (format "~S from ~S" sym rw))
|
||||
(values (add1 i)
|
||||
(list* tl new-toplevels)
|
||||
(list* (+ i toplevel-offset) remap))]
|
||||
[(module-path-index? rw)
|
||||
(values (add1 i)
|
||||
(list* tl new-toplevels)
|
||||
(list* (+ i toplevel-offset) remap))]
|
||||
[(modvar-rewrite? rw)
|
||||
(values i
|
||||
new-toplevels
|
||||
(list* (compute-new-modvar mv rw) remap))]
|
||||
[else
|
||||
(error 'filter-rewritable-module-variable? "Unsupported module-rewrite: ~S" rw)])]
|
||||
[tl
|
||||
(cond
|
||||
[(and new-#f-idx (not tl))
|
||||
(log-debug (format "[~S] dropping a #f at ~v that would have been at ~v but is now at ~v"
|
||||
name idx (+ i toplevel-offset) new-#f-idx))
|
||||
(values i
|
||||
new-toplevels
|
||||
(list* new-#f-idx remap))]
|
||||
[else
|
||||
(values (add1 i)
|
||||
(list* tl new-toplevels)
|
||||
(list* (+ i toplevel-offset) remap))])])))
|
||||
; XXX This would be more efficient as a vector
|
||||
(values (reverse new-toplevels)
|
||||
(reverse remap)))
|
||||
|
||||
(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 binding-names
|
||||
flags pre-submodules post-submodules))
|
||||
(define top-toplevels (prefix-toplevels top-prefix))
|
||||
(define toplevel-offset (length top-toplevels))
|
||||
(define topsyntax-offset (length (prefix-stxs top-prefix)))
|
||||
(define lift-offset (prefix-num-lifts top-prefix))
|
||||
(define mod-toplevels (prefix-toplevels mod-prefix))
|
||||
(define new-#f-idx
|
||||
(index-of #f top-toplevels))
|
||||
(when new-#f-idx
|
||||
(log-debug (format "[~S] found a #f entry in prefix already at ~v, squashing"
|
||||
name new-#f-idx)))
|
||||
(define-values (new-mod-toplevels toplevel-remap)
|
||||
(filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels))
|
||||
(define num-mod-toplevels
|
||||
(length toplevel-remap))
|
||||
(define mod-stxs
|
||||
(length (prefix-stxs mod-prefix)))
|
||||
(define mod-num-lifts
|
||||
(prefix-num-lifts mod-prefix))
|
||||
(define new-mod-prefix
|
||||
(struct-copy prefix mod-prefix
|
||||
[toplevels new-mod-toplevels]))
|
||||
(define offset-meta (vector name srcname self-modidx))
|
||||
(log-debug "Setting toplevel offsets rewriter for ~S and it is currently ~S"
|
||||
offset-meta
|
||||
(hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx #f))
|
||||
(hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx
|
||||
(toplevel-offset-rewriter
|
||||
(lambda (n)
|
||||
(log-debug "Finding offset ~a in ~S of ~S" n toplevel-remap offset-meta)
|
||||
(list-ref toplevel-remap n))
|
||||
offset-meta))
|
||||
(unless (= (length toplevel-remap)
|
||||
(length mod-toplevels))
|
||||
(error 'merge-module "Not remapping everything: ~S ~S"
|
||||
mod-toplevels toplevel-remap))
|
||||
(log-debug (format "[~S] Incrementing toplevels by ~a"
|
||||
name
|
||||
toplevel-offset))
|
||||
(log-debug (format "[~S] Incrementing lifts by ~a"
|
||||
name
|
||||
lift-offset))
|
||||
(log-debug (format "[~S] Filtered mod-vars from ~a to ~a"
|
||||
name
|
||||
(length mod-toplevels)
|
||||
(length new-mod-toplevels)))
|
||||
(values (max max-let-depth mod-max-let-depth)
|
||||
(merge-prefix top-prefix new-mod-prefix)
|
||||
(lambda (top-prefix)
|
||||
(log-debug (format "[~S] Updating top-levels" name))
|
||||
(define top-lift-start (prefix-lift-start top-prefix))
|
||||
(define mod-lift-start (prefix-lift-start mod-prefix))
|
||||
(define total-lifts (prefix-num-lifts top-prefix))
|
||||
(define max-toplevel (+ top-lift-start total-lifts))
|
||||
(define update
|
||||
(update-toplevels
|
||||
(lambda (n)
|
||||
(define new-idx
|
||||
(cond
|
||||
[(mod-lift-start . <= . n)
|
||||
(log-debug (format "[~S] ~v is a lift"
|
||||
name n))
|
||||
(define which-lift (- n mod-lift-start))
|
||||
(define lift-tl (+ top-lift-start lift-offset which-lift))
|
||||
(when (lift-tl . >= . max-toplevel)
|
||||
(error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)"
|
||||
name n which-lift num-mod-toplevels mod-num-lifts lift-tl))
|
||||
lift-tl]
|
||||
[else
|
||||
;; xxx maybe change this to a vector after it is made to make this efficient
|
||||
(list-ref toplevel-remap n)]))
|
||||
(log-debug (format "[~S] ~v is remapped to ~v"
|
||||
name n new-idx))
|
||||
new-idx)
|
||||
(lambda (n)
|
||||
(+ n topsyntax-offset))
|
||||
(prefix-syntax-start top-prefix)))
|
||||
(map update body)))]))
|
||||
|
||||
(provide/contract
|
||||
[merge-compilation-top (-> get-modvar-rewrite/c
|
||||
compilation-top?
|
||||
compilation-top?)])
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/list
|
||||
racket/match
|
||||
racket/contract
|
||||
compiler/zo-parse
|
||||
"util.rkt")
|
||||
|
||||
(define (->module-path-index s)
|
||||
(if (module-path-index? s)
|
||||
s
|
||||
(module-path-index-join `(quote ,s) #f)))
|
||||
|
||||
(define (wrap-in-kernel-module name srcname lang-info self-modidx top)
|
||||
(match top
|
||||
[(struct compilation-top (max-let-depth binding-namess prefix form))
|
||||
(define-values (reqs new-forms)
|
||||
(partition req? (splice-forms form)))
|
||||
(define requires
|
||||
(map (compose ->module-path-index stx-obj-datum stx-content req-reqs) reqs))
|
||||
(make-compilation-top
|
||||
0
|
||||
#hash()
|
||||
(make-prefix 0 (list #f) empty (prefix-src-inspector-desc prefix))
|
||||
(make-mod name srcname
|
||||
self-modidx
|
||||
prefix
|
||||
empty ; provides
|
||||
(list (cons 0 requires))
|
||||
new-forms
|
||||
empty ; syntax-body
|
||||
(list) ; unexported
|
||||
max-let-depth
|
||||
(make-toplevel 0 0 #f #f) ; dummy
|
||||
lang-info
|
||||
#t
|
||||
(hash) ; no names visible via `module->namespace`
|
||||
empty
|
||||
empty
|
||||
empty))]))
|
||||
|
||||
(provide/contract
|
||||
[wrap-in-kernel-module (symbol? symbol? lang-info/c module-path-index? compilation-top? . -> . compilation-top?)])
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/contract
|
||||
syntax/modresolve)
|
||||
|
||||
(define current-module-path (make-parameter #f))
|
||||
|
||||
(define (mpi->string modidx)
|
||||
(cond
|
||||
[(symbol? modidx) modidx]
|
||||
[else
|
||||
(mpi->path! modidx)]))
|
||||
|
||||
(define MODULE-PATHS (make-parameter #f))
|
||||
(define (mpi->path! mpi)
|
||||
(hash-ref!
|
||||
(MODULE-PATHS) mpi
|
||||
(lambda ()
|
||||
(define _pth
|
||||
(resolve-module-path-index mpi (current-module-path)))
|
||||
(cond
|
||||
[(path? _pth) (simplify-path _pth #t)]
|
||||
[(and (pair? _pth)
|
||||
(path? (cadr _pth)))
|
||||
(list* 'submod (simplify-path (cadr _pth) #t) (cddr _pth))]
|
||||
[else _pth]))))
|
||||
(define (mpi->path* mpi)
|
||||
(hash-ref (MODULE-PATHS) mpi
|
||||
(lambda ()
|
||||
(error 'mpi->path* "Cannot locate cache of path for ~S" mpi))))
|
||||
|
||||
(define submod-path/c
|
||||
(cons/c 'submod
|
||||
(cons/c (or/c symbol? path?)
|
||||
(listof symbol?))))
|
||||
|
||||
(provide/contract
|
||||
[MODULE-PATHS (parameter/c (or/c false/c hash?))]
|
||||
[current-module-path (parameter/c (or/c path-string? submod-path/c))]
|
||||
[mpi->path! (module-path-index? . -> . (or/c symbol? path? submod-path/c))]
|
||||
[mpi->path* (module-path-index? . -> . (or/c symbol? path? pair? submod-path/c))])
|
||||
|
|
@ -1,228 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/list
|
||||
racket/match
|
||||
racket/contract
|
||||
compiler/zo-parse
|
||||
"util.rkt"
|
||||
"mpi.rkt"
|
||||
racket/set)
|
||||
|
||||
(define current-excluded-modules (make-parameter (set)))
|
||||
|
||||
(define ZOS (make-parameter #f))
|
||||
(define MODULE-IDX-MAP (make-parameter #f))
|
||||
(define PHASE*MODULE-CACHE (make-parameter #f))
|
||||
|
||||
(define (nodep-file file-to-batch)
|
||||
(define idx-map (make-hash))
|
||||
(parameterize ([ZOS (make-hash)]
|
||||
[MODULE-IDX-MAP idx-map]
|
||||
[PHASE*MODULE-CACHE (make-hasheq)])
|
||||
(define (get-modvar-rewrite modidx)
|
||||
(define pth (mpi->path* modidx))
|
||||
(hash-ref idx-map pth
|
||||
(lambda ()
|
||||
(error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth))))
|
||||
(match (get-nodep-module-code/path file-to-batch 0)
|
||||
[(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop))))
|
||||
(values ctop lang-info (modvar-rewrite-modidx modvar-rewrite) get-modvar-rewrite)])))
|
||||
|
||||
(define (path->comp-top pth submod)
|
||||
(hash-ref! (ZOS) (cons pth submod)
|
||||
(λ ()
|
||||
(define zo (call-with-input-file pth zo-parse))
|
||||
(if submod
|
||||
(extract-submod zo submod)
|
||||
zo))))
|
||||
|
||||
(define (extract-submod zo submod)
|
||||
(define m (compilation-top-code zo))
|
||||
(struct-copy compilation-top
|
||||
zo
|
||||
[code (let loop ([m m])
|
||||
(if (and (pair? (mod-name m))
|
||||
(equal? submod (cdr (mod-name m))))
|
||||
m
|
||||
(or (ormap loop (mod-pre-submodules m))
|
||||
(ormap loop (mod-post-submodules m)))))]))
|
||||
|
||||
(define (excluded? pth)
|
||||
(and (path? pth)
|
||||
(set-member? (current-excluded-modules) (path->string pth))))
|
||||
|
||||
(define (get-nodep-module-code/index mpi phase)
|
||||
(define pth (mpi->path! mpi))
|
||||
(cond
|
||||
[(symbol? pth)
|
||||
(hash-set! (MODULE-IDX-MAP) pth pth)
|
||||
pth]
|
||||
[(excluded? pth)
|
||||
(hash-set! (MODULE-IDX-MAP) pth mpi)
|
||||
mpi]
|
||||
[else
|
||||
(get-nodep-module-code/path pth phase)]))
|
||||
|
||||
(define-struct @phase (phase code))
|
||||
(define-struct modvar-rewrite (modidx provide->toplevel))
|
||||
(define-struct module-code (modvar-rewrite lang-info ctop))
|
||||
(define @phase-ctop (compose module-code-ctop @phase-code))
|
||||
|
||||
(define (get-nodep-module-code/path pth phase)
|
||||
(define MODULE-CACHE
|
||||
(hash-ref! (PHASE*MODULE-CACHE) phase make-hash))
|
||||
(if (hash-ref MODULE-CACHE pth #f)
|
||||
#f
|
||||
(hash-ref!
|
||||
MODULE-CACHE pth
|
||||
(lambda ()
|
||||
(define-values (base file dir?) (split-path (if (path-string? pth)
|
||||
pth
|
||||
(cadr pth))))
|
||||
(define base-directory
|
||||
(if (path? base)
|
||||
(path->complete-path base (current-directory))
|
||||
(current-directory)))
|
||||
(define-values (modvar-rewrite lang-info ctop)
|
||||
(begin
|
||||
(log-debug (format "Load ~S @ ~S" pth phase))
|
||||
(nodep/dir
|
||||
(parameterize ([current-load-relative-directory base-directory])
|
||||
(path->comp-top
|
||||
(build-compiled-path
|
||||
base
|
||||
(path-add-suffix file #".zo"))
|
||||
(and (pair? pth) (cddr pth))))
|
||||
pth
|
||||
phase)))
|
||||
(when (and phase (zero? phase))
|
||||
(hash-set! (MODULE-IDX-MAP) pth modvar-rewrite))
|
||||
(make-@phase
|
||||
phase
|
||||
(make-module-code modvar-rewrite lang-info ctop))))))
|
||||
|
||||
(define (nodep/dir top pth phase)
|
||||
(define pth*
|
||||
(cond
|
||||
[(string? pth) (string->path pth)]
|
||||
[(list? pth) (cadr pth)]
|
||||
[else pth]))
|
||||
(parameterize ([current-module-path pth*])
|
||||
(nodep top phase)))
|
||||
|
||||
(define (nodep top phase)
|
||||
(match top
|
||||
[(struct compilation-top (max-let-depth binding-namess prefix form))
|
||||
(define-values (modvar-rewrite lang-info new-form) (nodep-form form phase))
|
||||
(values modvar-rewrite lang-info (make-compilation-top max-let-depth #hash() prefix new-form))]
|
||||
[else (error 'nodep "unrecognized: ~e" top)]))
|
||||
|
||||
(define (nodep-form form phase)
|
||||
(if (mod? form)
|
||||
(let-values ([(modvar-rewrite lang-info mods)
|
||||
(nodep-module form phase)])
|
||||
(values modvar-rewrite lang-info (make-splice mods)))
|
||||
(error 'nodep-form "Doesn't support non mod forms")))
|
||||
|
||||
; XXX interning is hack to fix test/add04.ss and provide/contract renaming
|
||||
(define (intern s) (string->symbol (symbol->string s)))
|
||||
(define (construct-provide->toplevel prefix provides)
|
||||
(define provide-ht (make-hasheq))
|
||||
(for ([tl (prefix-toplevels prefix)]
|
||||
[i (in-naturals)])
|
||||
(when (symbol? tl)
|
||||
(hash-set! provide-ht (intern tl) i)))
|
||||
(lambda (sym pos)
|
||||
(define isym (intern sym))
|
||||
(log-debug (format "Looking up ~S@~a [~S] in ~S" sym pos isym prefix))
|
||||
(define res
|
||||
(hash-ref provide-ht isym
|
||||
(lambda ()
|
||||
(error 'provide->toplevel "Cannot find ~S in ~S" sym prefix))))
|
||||
(log-debug (format "Looked up ~S@~a and got ~v" sym pos res))
|
||||
res))
|
||||
|
||||
(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 binding-names
|
||||
flags pre-submodules post-submodules))
|
||||
(define new-prefix prefix)
|
||||
;; Cache all the mpi paths
|
||||
(for-each (match-lambda
|
||||
[(and mv (struct module-variable (modidx sym pos phase constantness)))
|
||||
(mpi->path! modidx)]
|
||||
[tl
|
||||
(void)])
|
||||
(prefix-toplevels new-prefix))
|
||||
(define mvs (filter module-variable? (prefix-toplevels new-prefix)))
|
||||
(log-debug (format "[~S] module-variables: ~S - ~S" name (length mvs) mvs))
|
||||
(values (make-modvar-rewrite self-modidx (construct-provide->toplevel new-prefix provides))
|
||||
lang-info
|
||||
(append (requires->modlist requires phase)
|
||||
(if (and phase (zero? phase))
|
||||
(begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now
|
||||
(list (make-mod name srcname self-modidx
|
||||
new-prefix provides requires body empty
|
||||
unexported max-let-depth dummy lang-info internal-context #hash()
|
||||
empty empty empty)))
|
||||
(begin (log-debug (format "[~S] Dropping module @ ~S" name phase))
|
||||
empty))))]
|
||||
[else (error 'nodep-module "huh?: ~e" mod-form)]))
|
||||
|
||||
(define (+* l r)
|
||||
(if (and l r) (+ l r) #f))
|
||||
|
||||
(define (requires->modlist requires current-phase)
|
||||
(apply append
|
||||
(map
|
||||
(match-lambda
|
||||
[(list-rest req-phase mpis)
|
||||
(define phase (+* current-phase req-phase))
|
||||
(apply append
|
||||
(map (compose extract-modules (lambda (mpi) (get-nodep-module-code/index mpi phase))) mpis))])
|
||||
requires)))
|
||||
|
||||
(define (all-but-last l)
|
||||
(reverse (rest (reverse l))))
|
||||
|
||||
(define REQUIRED (make-hasheq))
|
||||
(define (extract-modules ct)
|
||||
(cond
|
||||
[(compilation-top? ct)
|
||||
(match (compilation-top-code ct)
|
||||
[(and m (? mod?))
|
||||
(list m)]
|
||||
[(struct splice (mods))
|
||||
mods])]
|
||||
[(symbol? ct)
|
||||
(if (hash-has-key? REQUIRED ct)
|
||||
empty
|
||||
(begin
|
||||
(hash-set! REQUIRED ct #t)
|
||||
(list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))]
|
||||
[(module-path-index? ct)
|
||||
(if (hash-has-key? REQUIRED ct)
|
||||
empty
|
||||
(begin
|
||||
(hash-set! REQUIRED ct #t)
|
||||
(list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))]
|
||||
[(not ct)
|
||||
empty]
|
||||
[(@phase? ct)
|
||||
(extract-modules (@phase-ctop ct))]
|
||||
[else
|
||||
(error 'extract-modules "Unknown extraction: ~S" ct)]))
|
||||
|
||||
(define get-modvar-rewrite/c
|
||||
(module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?)))
|
||||
(provide/contract
|
||||
[struct modvar-rewrite
|
||||
([modidx module-path-index?]
|
||||
[provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])]
|
||||
[get-modvar-rewrite/c contract?]
|
||||
[current-excluded-modules (parameter/c generic-set?)]
|
||||
[nodep-file (-> path-string?
|
||||
(values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))])
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/match
|
||||
racket/vector
|
||||
racket/struct
|
||||
"util.rkt")
|
||||
|
||||
(provide replace-modidx)
|
||||
|
||||
(define (replace-modidx expr self-modidx)
|
||||
(define (inner-update e)
|
||||
(match e
|
||||
[(app prefab-struct-key (and key (not #f)))
|
||||
(apply make-prefab-struct key
|
||||
(map update
|
||||
(struct->list e)))]
|
||||
[(? module-path-index?)
|
||||
(define-values (path mpi) (module-path-index-split e))
|
||||
(if (not path)
|
||||
self-modidx
|
||||
(module-path-index-join path (update mpi)))]
|
||||
[(cons a b)
|
||||
(cons (update a) (update b))]
|
||||
[(? vector?)
|
||||
(vector-map update e)]
|
||||
[else e]))
|
||||
(define-values (first-update update)
|
||||
(build-form-memo inner-update))
|
||||
(first-update expr))
|
||||
|
|
@ -1,108 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/match
|
||||
racket/contract
|
||||
compiler/zo-structs
|
||||
"util.rkt")
|
||||
|
||||
(define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt)
|
||||
(define (inner-update form)
|
||||
(match form
|
||||
[(struct def-values (ids rhs))
|
||||
(make-def-values (map update ids)
|
||||
(update rhs))]
|
||||
[(? def-syntaxes?)
|
||||
(error 'increment "Doesn't handle syntax")]
|
||||
[(? seq-for-syntax?)
|
||||
(error 'increment "Doesn't handle syntax")]
|
||||
[(struct inline-variant (direct inline))
|
||||
(update direct)]
|
||||
[(struct req (reqs dummy))
|
||||
(make-req reqs (update dummy))]
|
||||
[(? mod?)
|
||||
(error 'increment "Doesn't handle modules")]
|
||||
[(struct seq (forms))
|
||||
(make-seq (map update forms))]
|
||||
[(struct splice (forms))
|
||||
(make-splice (map update forms))]
|
||||
[(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body)))
|
||||
(struct-copy lam l
|
||||
[toplevel-map #f] ; conservative
|
||||
[body (update body)])]
|
||||
[(and c (struct closure (code gen-id)))
|
||||
(struct-copy closure c
|
||||
[code (update code)])]
|
||||
[(and cl (struct case-lam (name clauses)))
|
||||
(define new-clauses
|
||||
(map update clauses))
|
||||
(struct-copy case-lam cl
|
||||
[clauses new-clauses])]
|
||||
[(struct let-one (rhs body type unused?))
|
||||
(make-let-one (update rhs) (update body) type unused?)]
|
||||
[(and f (struct let-void (count boxes? body)))
|
||||
(struct-copy let-void f
|
||||
[body (update body)])]
|
||||
[(and f (struct install-value (_ _ _ rhs body)))
|
||||
(struct-copy install-value f
|
||||
[rhs (update rhs)]
|
||||
[body (update body)])]
|
||||
[(struct let-rec (procs body))
|
||||
(make-let-rec (map update procs) (update body))]
|
||||
[(and f (struct boxenv (_ body)))
|
||||
(struct-copy boxenv f [body (update body)])]
|
||||
[(and f (struct toplevel (_ pos _ _)))
|
||||
(struct-copy toplevel f
|
||||
[pos (toplevel-updater pos)])]
|
||||
[(and f (struct topsyntax (_ pos _)))
|
||||
(struct-copy topsyntax f
|
||||
[pos (topsyntax-updater pos)]
|
||||
[midpt topsyntax-new-midpt])]
|
||||
[(struct application (rator rands))
|
||||
(make-application
|
||||
(update rator)
|
||||
(map update rands))]
|
||||
[(struct branch (test then else))
|
||||
(make-branch
|
||||
(update test)
|
||||
(update then)
|
||||
(update else))]
|
||||
[(struct with-cont-mark (key val body))
|
||||
(make-with-cont-mark
|
||||
(update key)
|
||||
(update val)
|
||||
(update body))]
|
||||
[(struct with-immed-mark (key val body))
|
||||
(make-with-immed-mark
|
||||
(update key)
|
||||
(update val)
|
||||
(update body))]
|
||||
[(struct beg0 (seq))
|
||||
(make-beg0 (map update seq))]
|
||||
[(struct varref (tl dummy))
|
||||
(make-varref (update tl) (update dummy))]
|
||||
[(and f (struct assign (id rhs undef-ok?)))
|
||||
(struct-copy assign f
|
||||
[id (update id)]
|
||||
[rhs (update rhs)])]
|
||||
[(struct apply-values (proc args-expr))
|
||||
(make-apply-values
|
||||
(update proc)
|
||||
(update args-expr))]
|
||||
[(and f (struct primval (id)))
|
||||
f]
|
||||
[(and f (struct localref (unbox? pos clear? other-clears? type)))
|
||||
f]
|
||||
[(and f (not (? form?)))
|
||||
f]
|
||||
))
|
||||
(define-values (first-update update)
|
||||
(build-form-memo inner-update))
|
||||
first-update)
|
||||
|
||||
(provide/contract
|
||||
[update-toplevels
|
||||
((exact-nonnegative-integer? . -> . exact-nonnegative-integer?)
|
||||
(exact-nonnegative-integer? . -> . exact-nonnegative-integer?)
|
||||
exact-nonnegative-integer?
|
||||
. -> .
|
||||
(form? . -> . form?))])
|
||||
|
|
@ -1,79 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/contract
|
||||
compiler/zo-parse)
|
||||
|
||||
(define (prefix-syntax-start pre)
|
||||
(length (prefix-toplevels pre)))
|
||||
|
||||
(define (prefix-lift-start pre)
|
||||
(define syntax-start (prefix-syntax-start pre))
|
||||
(define total-stxs (length (prefix-stxs pre)))
|
||||
(+ syntax-start total-stxs (if (zero? total-stxs) 0 1)))
|
||||
|
||||
(struct nothing ())
|
||||
|
||||
(define-syntax-rule (eprintf* . args) (void))
|
||||
|
||||
(define (build-form-memo inner-update #:void? [void? #f])
|
||||
(define memo (make-hasheq))
|
||||
(define (update form . args)
|
||||
(eprintf* "Updating on ~a\n" form)
|
||||
(define fin
|
||||
(cond
|
||||
[(hash-ref memo form #f)
|
||||
=> (λ (x)
|
||||
(eprintf* "Found in memo table\n")
|
||||
x)]
|
||||
[else
|
||||
(eprintf* "Not in memo table\n")
|
||||
(let ()
|
||||
(define ph (make-placeholder (nothing)))
|
||||
(hash-set! memo form ph)
|
||||
(define nv (nothing))
|
||||
(dynamic-wind void
|
||||
(λ ()
|
||||
(set! nv (apply inner-update form args)))
|
||||
(λ ()
|
||||
(if (nothing? nv)
|
||||
(eprintf* "inner-update returned nothing (or there was an escape) on ~a\n" form)
|
||||
(begin
|
||||
(placeholder-set! ph nv)
|
||||
(hash-set! memo form nv)))))
|
||||
nv)]))
|
||||
(eprintf* "Updating on ~a ---->\n ~a\n" form fin)
|
||||
fin)
|
||||
(define (first-update form . args)
|
||||
(eprintf* "Top level update on ~a\n" form)
|
||||
(define final (apply update form args))
|
||||
(eprintf* "Top level update on ~a ---->\n ~a\n" form final)
|
||||
(define fin (make-reader-graph final))
|
||||
(eprintf* "Top level update on ~a ---->\n ~a [after reader-graph]\n" form fin)
|
||||
fin)
|
||||
(values first-update update))
|
||||
|
||||
(define lang-info/c
|
||||
(or/c #f (vector/c module-path? symbol? any/c)))
|
||||
|
||||
|
||||
(define (build-compiled-path base name)
|
||||
(build-path
|
||||
(cond [(path? base) base]
|
||||
[(eq? base 'relative) 'same]
|
||||
[(eq? base #f) (error 'batch "Impossible")])
|
||||
"compiled"
|
||||
name))
|
||||
|
||||
|
||||
(provide/contract
|
||||
[prefix-syntax-start (prefix? . -> . exact-nonnegative-integer?)]
|
||||
[prefix-lift-start (prefix? . -> . exact-nonnegative-integer?)]
|
||||
[eprintf ((string?) () #:rest (listof any/c) . ->* . void)]
|
||||
[build-form-memo
|
||||
(((unconstrained-domain-> any/c))
|
||||
(#:void? boolean?)
|
||||
. ->* .
|
||||
(values (unconstrained-domain-> any/c)
|
||||
(unconstrained-domain-> any/c)))]
|
||||
[lang-info/c contract?]
|
||||
[build-compiled-path ((or/c path-string? (symbols 'relative) false/c) path-string? . -> . (or/c path-string? (symbols 'same 'up)))])
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
|
||||
(module embed-sig racket/base
|
||||
(require racket/unit)
|
||||
(provide compiler:embed^)
|
||||
|
||||
(define-signature compiler:embed^
|
||||
(create-embedding-executable
|
||||
make-embedding-executable
|
||||
write-module-bundle
|
||||
embedding-executable-is-directory?
|
||||
embedding-executable-is-actually-directory?
|
||||
embedding-executable-put-file-extension+style+filters
|
||||
embedding-executable-add-suffix)))
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/unit
|
||||
racket/contract
|
||||
"sig.rkt"
|
||||
compiler/embed
|
||||
"embed-sig.rkt")
|
||||
|
||||
(define-unit-from-context compiler:embed@ compiler:embed^)
|
||||
(provide compiler:embed@)
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/unit compiler/sig compiler/option)
|
||||
|
||||
(provide compiler:option@)
|
||||
|
||||
(define-unit-from-context compiler:option@ compiler:option^)
|
||||
|
|
@ -1,39 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/unit)
|
||||
|
||||
(provide compiler:option^
|
||||
compiler^)
|
||||
|
||||
;; Compiler options
|
||||
(define-signature compiler:option^
|
||||
(somewhat-verbose ; default = #f
|
||||
verbose ; default = #f
|
||||
|
||||
|
||||
setup-prefix ; string to embed in public names;
|
||||
; used mainly for compiling extensions
|
||||
; with the collection name so that
|
||||
; cross-extension conflicts are less
|
||||
; likely in architectures that expose
|
||||
; the public names of loaded extensions
|
||||
; default = ""
|
||||
|
||||
3m ; #t => build for 3m
|
||||
; default = #f
|
||||
|
||||
compile-subcollections ; #t => compile collection subdirectories
|
||||
; default = #t
|
||||
|
||||
))
|
||||
|
||||
;; Compiler procedures
|
||||
(define-signature compiler^
|
||||
(compile-zos
|
||||
|
||||
compile-collection-zos
|
||||
compile-directory-zos
|
||||
compile-directory-srcs
|
||||
|
||||
current-compiler-dynamic-require-wrapper
|
||||
compile-notify-handler))
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define collection 'multi)
|
||||
|
||||
(define deps '(["base" #:version "6.5.0.2"]
|
||||
"scheme-lib"
|
||||
"rackunit-lib"
|
||||
"zo-lib"))
|
||||
|
||||
(define implies '("zo-lib"))
|
||||
|
||||
(define pkg-desc "implementation (no documentation) part of \"compiler\"")
|
||||
|
||||
(define pkg-authors '(mflatt))
|
||||
|
||||
(define version "1.4")
|
||||
|
|
@ -1,57 +0,0 @@
|
|||
#lang racket/signature
|
||||
|
||||
make-gracket-launcher
|
||||
make-racket-launcher
|
||||
make-mred-launcher
|
||||
make-mzscheme-launcher
|
||||
|
||||
make-gracket-program-launcher
|
||||
make-racket-program-launcher
|
||||
make-mred-program-launcher
|
||||
make-mzscheme-program-launcher
|
||||
|
||||
gracket-program-launcher-path
|
||||
racket-program-launcher-path
|
||||
mred-program-launcher-path
|
||||
mzscheme-program-launcher-path
|
||||
|
||||
install-gracket-program-launcher
|
||||
install-racket-program-launcher
|
||||
install-mred-program-launcher
|
||||
install-mzscheme-program-launcher
|
||||
|
||||
gracket-launcher-up-to-date?
|
||||
racket-launcher-up-to-date?
|
||||
mred-launcher-up-to-date?
|
||||
mzscheme-launcher-up-to-date?
|
||||
|
||||
gracket-launcher-is-directory?
|
||||
racket-launcher-is-directory?
|
||||
mred-launcher-is-directory?
|
||||
mzscheme-launcher-is-directory?
|
||||
|
||||
gracket-launcher-is-actually-directory?
|
||||
racket-launcher-is-actually-directory?
|
||||
mred-launcher-is-actually-directory?
|
||||
mzscheme-launcher-is-actually-directory?
|
||||
|
||||
gracket-launcher-add-suffix
|
||||
racket-launcher-add-suffix
|
||||
mred-launcher-add-suffix
|
||||
mzscheme-launcher-add-suffix
|
||||
|
||||
gracket-launcher-put-file-extension+style+filters
|
||||
racket-launcher-put-file-extension+style+filters
|
||||
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
|
||||
available-gracket-variants
|
||||
available-racket-variants
|
||||
|
||||
installed-executable-path->desktop-path
|
||||
installed-desktop-path->icon-path
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/unit "launcher-sig.rkt" launcher/launcher)
|
||||
|
||||
(provide launcher@)
|
||||
|
||||
(define-unit-from-context launcher@ launcher^)
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
(module option-sig racket/base
|
||||
(require racket/unit)
|
||||
|
||||
(provide setup-option^)
|
||||
|
||||
(define-signature setup-option^
|
||||
(setup-program-name
|
||||
verbose
|
||||
make-verbose
|
||||
compiler-verbose
|
||||
clean
|
||||
compile-mode
|
||||
make-only
|
||||
make-zo
|
||||
make-info-domain
|
||||
make-foreign-libs
|
||||
make-launchers
|
||||
make-docs
|
||||
make-user
|
||||
make-planet
|
||||
avoid-main-installation
|
||||
make-tidy
|
||||
make-doc-index
|
||||
check-dependencies
|
||||
fix-dependencies
|
||||
call-install
|
||||
call-post-install
|
||||
pause-on-errors
|
||||
parallel-workers
|
||||
force-unpacks
|
||||
doc-pdf-dest
|
||||
specific-collections
|
||||
specific-planet-dirs
|
||||
archives
|
||||
archive-implies-reindex
|
||||
current-target-directory-getter
|
||||
current-target-plt-directory-getter)))
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/unit setup/option "option-sig.rkt")
|
||||
|
||||
(provide setup:option@ set-flag-params)
|
||||
|
||||
(define-unit-from-context setup:option@ setup-option^)
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/unit setup/setup-core)
|
||||
|
||||
(provide setup@)
|
||||
(define-unit setup@
|
||||
(import)
|
||||
(export)
|
||||
(setup-core))
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
compiler-test
|
||||
Copyright (c) 2010-2014 PLT Design Inc.
|
||||
|
||||
This package is distributed under the GNU Lesser General Public
|
||||
License (LGPL). This means that you can link this package into proprietary
|
||||
applications, provided you follow the rules stated in the LGPL. You
|
||||
can also modify this package; if you distribute a modified version,
|
||||
you must distribute it under the terms of the LGPL, which in
|
||||
particular means that you must release the source code for the
|
||||
modified software. See http://www.gnu.org/copyleft/lesser.html
|
||||
for more information.
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define collection 'multi)
|
||||
|
||||
(define deps '("base"))
|
||||
|
||||
(define pkg-desc "tests for \"compiler-lib\"")
|
||||
|
||||
(define pkg-authors '(mflatt))
|
||||
(define build-deps '("compiler-lib"
|
||||
"eli-tester"
|
||||
"rackunit-lib"
|
||||
"net-lib"
|
||||
"scheme-lib"
|
||||
"compatibility-lib"
|
||||
"gui-lib"
|
||||
"htdp-lib"
|
||||
"plai-lib"
|
||||
"rackunit-lib"))
|
||||
(define update-implies '("compiler-lib"))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket
|
||||
(require compiler/compiler)
|
||||
|
||||
;; minimal sanity check:
|
||||
(compile-collection-zos "setup")
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket
|
||||
(require rackunit)
|
||||
(require (only-in (submod compiler/commands/test paths) collection-paths))
|
||||
|
||||
(check-exn exn? (lambda () (collection-paths ".")))
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
#lang racket
|
||||
(require setup/dirs)
|
||||
|
||||
(define raco (build-path (find-console-bin-dir)
|
||||
(if (eq? (system-type) 'windows)
|
||||
"raco.exe"
|
||||
"raco")))
|
||||
|
||||
(define tmp (make-temporary-file))
|
||||
|
||||
(system* raco
|
||||
"ctool"
|
||||
"--3m"
|
||||
"--c-mods"
|
||||
tmp
|
||||
"++lib"
|
||||
"racket")
|
||||
|
||||
(delete-file tmp)
|
||||
|
|
@ -1,53 +0,0 @@
|
|||
#lang racket
|
||||
(require tests/eli-tester
|
||||
racket/runtime-path
|
||||
compiler/find-exe)
|
||||
|
||||
(define (capture-output command . args)
|
||||
(define o (open-output-string))
|
||||
(define e (open-output-string))
|
||||
(parameterize ([current-input-port (open-input-string "")]
|
||||
[current-output-port o]
|
||||
[current-error-port e])
|
||||
(apply system* command args))
|
||||
(values (get-output-string o) (get-output-string e)))
|
||||
|
||||
(define (test-on-program filename)
|
||||
;; run modular program, capture output
|
||||
(define-values (modular-output modular-error)
|
||||
(capture-output (find-exe) filename))
|
||||
|
||||
(define demod-filename
|
||||
(let-values ([(base filename dir?) (split-path filename)])
|
||||
(path->string
|
||||
(build-path
|
||||
(find-system-path 'temp-dir)
|
||||
(path-add-suffix filename #"_merged.zo")))))
|
||||
|
||||
;; demodularize
|
||||
(parameterize ([current-input-port (open-input-string "")])
|
||||
(system* (find-exe) "-l-" "raco" "demod" "-o" demod-filename filename))
|
||||
|
||||
;; run whole program
|
||||
(define-values (whole-output whole-error)
|
||||
(capture-output (find-exe) demod-filename))
|
||||
|
||||
;; compare output
|
||||
(test
|
||||
#:failure-prefix (format "~a stdout" filename)
|
||||
whole-output => modular-output
|
||||
#:failure-prefix (format "~a stderr" filename)
|
||||
whole-error => modular-error))
|
||||
|
||||
(define-runtime-path tests "tests")
|
||||
|
||||
(define (modular-program? filename)
|
||||
(and (not (regexp-match #rx"merged" filename))
|
||||
(regexp-match #rx"rkt$" filename)))
|
||||
|
||||
(test
|
||||
(for ([i (in-list (directory-list tests))])
|
||||
(define ip (build-path tests i))
|
||||
(when (modular-program? ip)
|
||||
(printf "Checking ~a\n" ip)
|
||||
(test-on-program (path->string ip)))))
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define test-timeouts '(("demod-test.rkt" 300)))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang racket/base
|
||||
5
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
(module kernel-5 '#%kernel
|
||||
(#%require racket/private/map)
|
||||
(define-values (id) (λ (x) x))
|
||||
(define-values (xs) (list 1 2 3 4 5))
|
||||
(map id (map id xs)))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang racket
|
||||
5
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
;; The first three lines of this file were inserted by DrRacket. They record metadata
|
||||
;; about the language level of this file in a form that our tools can easily process.
|
||||
#reader(lib "htdp-advanced-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
|
||||
10
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
;; The first three lines of this file were inserted by DrRacket. They record metadata
|
||||
;; about the language level of this file in a form that our tools can easily process.
|
||||
#reader(lib "htdp-beginner-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
|
||||
10
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
;; The first three lines of this file were inserted by DrRacket. They record metadata
|
||||
;; about the language level of this file in a form that our tools can easily process.
|
||||
#reader(lib "htdp-beginner-abbr-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
|
||||
10
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
;; The first three lines of this file were inserted by DrRacket. They record metadata
|
||||
;; about the language level of this file in a form that our tools can easily process.
|
||||
#reader(lib "htdp-intermediate-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
|
||||
10
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
;; The first three lines of this file were inserted by DrRacket. They record metadata
|
||||
;; about the language level of this file in a form that our tools can easily process.
|
||||
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
|
||||
10
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
(module embed-me1 mzscheme
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 1\n"))
|
||||
'append))
|
||||
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
(module embed-me10 mzscheme
|
||||
(require openssl/mzssl)
|
||||
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda ()
|
||||
(printf "~a\n" ssl-available?))
|
||||
'append))
|
||||
|
||||
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
(module embed-me11-rd mzscheme
|
||||
(provide (rename *read-syntax read-syntax)
|
||||
(rename *read read))
|
||||
|
||||
(define (*read port)
|
||||
`(module embed-me11 mzscheme
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda ()
|
||||
(printf ,(read port)
|
||||
;; Use `getenv' at read time!!!
|
||||
,(getenv "ELEVEN")))
|
||||
'append)))
|
||||
|
||||
(define (*read-syntax src port)
|
||||
(*read port)))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#reader(lib "embed-me11-rd.ss" "tests" "compiler" "embed")
|
||||
"It goes to ~a!\n"
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
(module embed-me11-rd mzscheme
|
||||
(provide (rename *read-syntax read-syntax)
|
||||
(rename *read read))
|
||||
|
||||
(define (*read port)
|
||||
`(module embed-me11 mzscheme
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda ()
|
||||
(printf ,(read port)
|
||||
;; Use `getenv' at read time!!!
|
||||
,(getenv "ELEVEN")))
|
||||
'append)))
|
||||
|
||||
(define (*read-syntax src port)
|
||||
(*read port)))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#reader(lib "embed-me12-rd.rkt" "tests" "compiler" "embed")
|
||||
"It goes to ~a!\n"
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/runtime-path)
|
||||
(define-runtime-module-path-index _mod "embed-me14.rkt")
|
||||
(dynamic-require _mod #f)
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
(require "embed-me13.rkt")
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 14\n"))
|
||||
#:exists 'append)
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
#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))
|
||||
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (submod "embed-me15-one.rkt" one))
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is ~a.\n" (+ 9 one two three)))
|
||||
#:exists 'append)
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
;; a `main' submodule:
|
||||
(module main racket/base
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 16.\n"))
|
||||
#:exists 'append))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (submod "embed-me17a.rkt" sub))
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(define print-17
|
||||
(lambda () (printf "This is 17.\n")))
|
||||
|
||||
(module+ sub
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
print-17
|
||||
#:exists 'append))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (submod tests/compiler/embed/embed-me18a sub))
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(dynamic-require '(submod tests/compiler/embed/embed-me18a sub) 'print-18)
|
||||
#:exists 'append)
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang racket/base
|
||||
(module sub racket/base
|
||||
(provide print-18)
|
||||
(define (print-18)
|
||||
(printf "This is 18.\n")))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/runtime-path)
|
||||
|
||||
(define-runtime-module-path plai plai)
|
||||
(define-runtime-module-path plai-reader plai/lang/reader)
|
||||
(define-runtime-module-path runtime racket/runtime-config)
|
||||
|
||||
(parameterize ([read-accept-reader #t])
|
||||
(namespace-require 'racket/base)
|
||||
(eval (read (open-input-string "#lang plai 10"))))
|
||||
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 19.\n"))
|
||||
#:exists 'append)
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/runtime-path
|
||||
(for-syntax scheme/base))
|
||||
(define-runtime-path file '(lib "icons/file.gif"))
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 1b\n"))
|
||||
#:exists 'append)
|
||||
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/runtime-path
|
||||
(for-syntax scheme/base))
|
||||
(define-runtime-path file '(lib "etc.ss")) ; in mzlib
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 1c\n"))
|
||||
#:exists 'append)
|
||||
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/runtime-path
|
||||
(for-syntax scheme/base))
|
||||
(define-runtime-path file '(lib "file.gif" "icons"))
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 1d\n"))
|
||||
#:exists 'append)
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/runtime-path
|
||||
(for-syntax scheme/base))
|
||||
(define-runtime-path file '(lib "html"))
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 1e\n"))
|
||||
#:exists 'append)
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/runtime-path)
|
||||
|
||||
;; Check that relative paths are preserved:
|
||||
(define-runtime-path f1 "embed-me1f1.rktl")
|
||||
(define-runtime-path f2 "sub/embed-me1f2.rktl")
|
||||
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (parameterize ([current-namespace (make-base-namespace)])
|
||||
(load f1)))
|
||||
#:exists 'append)
|
||||
|
|
@ -1 +0,0 @@
|
|||
(load-relative "sub/embed-me1f2.rktl")
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
(module embed-me2 mzscheme
|
||||
(require "embed-me1.ss"
|
||||
mzlib/etc)
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 2: ~a\n" true))
|
||||
'append))
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
;; like "embed-me16.rkt" using `module+'
|
||||
(module+ main
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 20.\n"))
|
||||
#:exists 'append))
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/match)
|
||||
|
||||
;; check using `racket/match', particularly with a pattern
|
||||
;; that eneds run-time support that may go through a
|
||||
;; compile-time `lazy-require':
|
||||
|
||||
(match "x"
|
||||
[(pregexp "x")
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 21.\n"))
|
||||
#:exists 'append)])
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
#lang racket/kernel
|
||||
|
||||
(printf "This is 22.\n")
|
||||
|
||||
(module configure-runtime racket/kernel
|
||||
(printf "Configure!\n"))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/serialize)
|
||||
|
||||
(serializable-struct foo (a b))
|
||||
|
||||
(define f (deserialize (serialize (foo 1 2))))
|
||||
(foo-a f)
|
||||
(foo-b f)
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
"Ok"
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(module+ main
|
||||
12)
|
||||
|
||||
(module submod racket/base
|
||||
11)
|
||||
|
||||
10
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(module+ main
|
||||
12)
|
||||
|
||||
(module submod racket/base
|
||||
11)
|
||||
|
||||
10
|
||||
(require (submod "embed-me27.rkt" other-submod))
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(module+ other-submod 'y)
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/place)
|
||||
|
||||
(define (go)
|
||||
(place pch
|
||||
(place-channel-put pch 28)))
|
||||
|
||||
(module+ main
|
||||
(define p (go))
|
||||
(define n (place-channel-get p))
|
||||
(void (place-wait p))
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "~a\n" n))
|
||||
#:exists 'append))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(module inside racket/base
|
||||
(define inside 'inside)
|
||||
(provide inside))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(module main racket/base
|
||||
(require (submod "embed-me29-2.rkt" inside))
|
||||
inside)
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
(module embed-me3 mzscheme
|
||||
(require mzlib/etc)
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda ()
|
||||
(printf "3 is here, too? ~a\n" true))
|
||||
'append))
|
||||
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
(with-output-to-file "stdout"
|
||||
(lambda () (printf "This is the literal expression 4.\n"))
|
||||
'append)
|
||||
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
(module embed-me5 mzscheme
|
||||
(require mred)
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 5: ~s\n" button%))
|
||||
'append))
|
||||
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
(module embed-me6 mzscheme
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda ()
|
||||
(printf "This is 6\n")
|
||||
(with-handlers ([void (lambda (exn) (printf "no etc.ss\n"))])
|
||||
(printf "~a\n" (dynamic-require 'mzlib/etc 'true))))
|
||||
'append))
|
||||
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
(module embed-me6b racket/base
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda ()
|
||||
(printf "This is 6\n")
|
||||
(with-handlers ([void (lambda (exn) (printf "no etc.ss\n"))])
|
||||
(printf "~a\n" (and (dynamic-require 'racket/fixnum #f) #t))))
|
||||
#:exists 'append))
|
||||
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
#include "escheme.h"
|
||||
|
||||
Scheme_Object *ex(int argc, Scheme_Object **argv)
|
||||
{
|
||||
return scheme_make_utf8_string("Hello, world!");
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_reload(Scheme_Env *env)
|
||||
{
|
||||
Scheme_Env *menv;
|
||||
|
||||
menv = scheme_primitive_module(scheme_intern_symbol("embed-me8"),
|
||||
env);
|
||||
|
||||
scheme_add_global("ex", scheme_make_prim_w_arity(ex, "ex", 0, 0), menv);
|
||||
|
||||
scheme_finish_primitive_module(menv);
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_initialize(Scheme_Env *env)
|
||||
{
|
||||
/* First load is same as every load: */
|
||||
return scheme_reload(env);
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_module_name()
|
||||
{
|
||||
return scheme_intern_symbol("embed-me8");
|
||||
}
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
(module embed-me9 mzscheme
|
||||
(require "embed-me8.ss")
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda ()
|
||||
(printf "~a\n" (ex)))
|
||||
'append)
|
||||
|
||||
(module test racket/base))
|
||||
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/place)
|
||||
|
||||
(provide go)
|
||||
|
||||
(define (go ch)
|
||||
(place-channel-put ch 42))
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
#lang racket/base
|
||||
(require "main.rkt")
|
||||
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
#:exists 'append
|
||||
(lambda () (displayln "alt")))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (submod (planet racket-tester/p1/has-sub) the-sub))
|
||||
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
#:exists 'append
|
||||
(lambda () (displayln (dynamic-require
|
||||
'(submod (planet racket-tester/p1/has-sub) the-sub)
|
||||
'out))))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user