diff --git a/compiler-lib/LICENSE.txt b/compiler-lib/LICENSE.txt new file mode 100644 index 0000000000..e3fb23eec0 --- /dev/null +++ b/compiler-lib/LICENSE.txt @@ -0,0 +1,11 @@ +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. diff --git a/compiler-lib/compiler/bundle-dist.rkt b/compiler-lib/compiler/bundle-dist.rkt new file mode 100644 index 0000000000..af419cf515 --- /dev/null +++ b/compiler-lib/compiler/bundle-dist.rkt @@ -0,0 +1,94 @@ + +(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")]))))) diff --git a/compiler-lib/compiler/commands/decompile.rkt b/compiler-lib/compiler/commands/decompile.rkt new file mode 100644 index 0000000000..bada535b72 --- /dev/null +++ b/compiler-lib/compiler/commands/decompile.rkt @@ -0,0 +1,90 @@ +#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 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" + " 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)))))))))) diff --git a/compiler-lib/compiler/commands/exe-dir.rkt b/compiler-lib/compiler/commands/exe-dir.rkt new file mode 100644 index 0000000000..acc3b94919 --- /dev/null +++ b/compiler-lib/compiler/commands/exe-dir.rkt @@ -0,0 +1,33 @@ +#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 as main collects for executables" + (exe-embedded-collects-path path)] + #:multi + [("++collects-copy") dir "Add collects in 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) diff --git a/compiler-lib/compiler/commands/exe.rkt b/compiler-lib/compiler/commands/exe.rkt new file mode 100644 index 0000000000..023ef4d671 --- /dev/null +++ b/compiler-lib/compiler/commands/exe.rkt @@ -0,0 +1,155 @@ +#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 " + (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 as configuration directory for executable" + (exe-embedded-config-path path)] + [("--collects-path") path "Set as main collects for executable" + (exe-embedded-collects-path path)] + [("--collects-dest") dir "Write collection code to " + (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 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 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) diff --git a/compiler-lib/compiler/commands/expand.rkt b/compiler-lib/compiler/commands/expand.rkt new file mode 100644 index 0000000000..dba76ae93d --- /dev/null +++ b/compiler-lib/compiler/commands/expand.rkt @@ -0,0 +1,42 @@ +#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 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) + diff --git a/compiler-lib/compiler/commands/info.rkt b/compiler-lib/compiler/commands/info.rkt new file mode 100644 index 0000000000..d8f9753937 --- /dev/null +++ b/compiler-lib/compiler/commands/info.rkt @@ -0,0 +1,15 @@ +#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))) diff --git a/compiler-lib/compiler/commands/make.rkt b/compiler-lib/compiler/commands/make.rkt new file mode 100644 index 0000000000..f9b7f3a611 --- /dev/null +++ b/compiler-lib/compiler/commands/make.rkt @@ -0,0 +1,119 @@ +#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 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))]) diff --git a/compiler-lib/compiler/commands/pack.rkt b/compiler-lib/compiler/commands/pack.rkt new file mode 100644 index 0000000000..ebb56ae73a --- /dev/null +++ b/compiler-lib/compiler/commands/pack.rkt @@ -0,0 +1,99 @@ +#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") "s specify collections instead of files/dirs" + (collection? #t)] + [("--plt-name") name "Set the printed 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 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) diff --git a/compiler-lib/compiler/commands/read.rkt b/compiler-lib/compiler/commands/read.rkt new file mode 100644 index 0000000000..2f18e3530e --- /dev/null +++ b/compiler-lib/compiler/commands/read.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(require (submod "expand.rkt" expand)) + +(show-program (lambda (e) e)) diff --git a/compiler-lib/compiler/commands/test.rkt b/compiler-lib/compiler/commands/test.rkt new file mode 100644 index 0000000000..7416398815 --- /dev/null +++ b/compiler-lib/compiler/commands/test.rkt @@ -0,0 +1,1077 @@ +#lang racket/base +(require racket/cmdline + racket/match + racket/format + racket/list + racket/function + racket/port + racket/path + racket/place + racket/future + racket/file + compiler/find-exe + raco/command-name + racket/system + rackunit/log + pkg/lib + pkg/path + setup/collects + setup/getinfo + compiler/module-suffix) + +(define rx:default-suffixes (get-module-suffix-regexp)) +;; For any other file suffix, a `test-command-line-arguments` +;; entry is required in "info.rkt". + +(define submodules '()) ; '() means "default" +(define configure-runtime 'default) +(define first-avail? #f) +(define run-anyways? #t) +(define quiet? #f) +(define quiet-program? #f) +(define check-stderr? #f) +(define table? #f) +(define fresh-user? #f) +(define empty-input? #f) +(define heartbeat-secs #f) +(define ignore-stderr-patterns null) + +(define jobs 0) ; 0 mean "default" +(define task-sema (make-semaphore 1)) + +(define default-timeout #f) ; #f means "none" +(define default-mode #f) ; #f => depends on how many files are provided + +(define single-file? #t) + +(define lock-file-dir (or (getenv "PLTLOCKDIR") + (find-system-path 'temp-dir))) +(define max-lock-delay (or (let ([n (string->number (or (getenv "PLTLOCKTIME") ""))]) + (and (real? n) + n)) + (* 4 60 60))) ; default: wait at most 4 hours + +(define test-exe-name (string->symbol (short-program+command-name))) + +;; Stub for running a test in a process: +(module process racket/base + (require rackunit/log + racket/file) + ;; Arguments are a temp file to hold test results, the module + ;; path to run, and the `dynamic-require` second argument: + (define argv (current-command-line-arguments)) + (define result-file (vector-ref argv 0)) + (define test-module (read (open-input-string (vector-ref argv 1)))) + (define rt-module (read (open-input-string (vector-ref argv 2)))) + (define d (read (open-input-string (vector-ref argv 3)))) + (define args (list-tail (vector->list argv) 4)) + + ;; In case PLTUSERHOME is set, make sure relevant + ;; directories exist: + (define (ready-dir d) + (make-directory* d)) + (ready-dir (find-system-path 'doc-dir)) + + (parameterize ([current-command-line-arguments (list->vector args)]) + (when rt-module (dynamic-require rt-module d)) + (dynamic-require test-module d) + ((executable-yield-handler) 0)) + + (call-with-output-file* + result-file + #:exists 'truncate + (lambda (o) + (write (test-log #:display? #f #:exit? #f) o))) + (exit 0)) + +;; Driver for running a test in a place: +(module place racket/base + (require racket/place + rackunit/log) + (provide go) + (define (go pch) + (define l (place-channel-get pch)) + ;; Run the test: + (parameterize ([current-command-line-arguments (list->vector + (cadddr (cdr l)))] + [current-directory (cadddr l)]) + (when (cadr l) (dynamic-require (cadr l) (caddr l))) + (dynamic-require (car l) (caddr l)) + ((executable-yield-handler) 0)) + ;; If the tests use `rackunit`, collect result stats: + (define test-results + (test-log #:display? #f #:exit? #f)) + + ;; Return test results. If we don't get this far, the result + ;; code of the place determines whether it the test counts as + ;; successful. + (place-channel-put pch + ;; If the test did not use `rackunit`, claim + ;; success: + (if (zero? (cdr test-results)) + (cons 0 1) + test-results)))) + +;; Run each test in its own place or process, and collect both test +;; results and whether any output went to stderr. +(define (dynamic-require-elsewhere p rt-p d args + #:id id + #:mode [mode (or default-mode + (if single-file? + 'direct + 'process))] + #:timeout timeout + #:responsible responsible + #:lock-name lock-name + #:random? random?) + (define c (make-custodian)) + (define timeout? #f) + (with-handlers ([exn:fail? (lambda (exn) + (custodian-shutdown-all c) + (unless quiet? + (eprintf "~a: ~a\n" + (extract-file-name p) + (exn-message exn))) + (summary 1 1 (current-label) #f (if timeout? 1 0)))]) + (define (go) + (define e (open-output-bytes)) + + (define stdout (if quiet-program? + (open-output-nowhere) + (current-output-port))) + (define stderr (if quiet-program? + e + (if check-stderr? + (tee-output-port (current-error-port) e) + (current-error-port)))) + (define stdin (if empty-input? + (open-input-bytes #"") + (current-input-port))) + + (unless quiet? + (when responsible + (fprintf stdout "raco test:~a @(test-responsible '~s)\n" + id + responsible)) + (when random? + (fprintf stdout "raco test:~a @(test-random #t)\n" + id)) + (when lock-name + (fprintf stdout "raco test:~a @(lock-name ~s)\n" + id + lock-name)) + (flush-output stdout)) + + (define-values (result-code test-results) + (case mode + [(direct) + (define pre (test-log #:display? #f #:exit? #f)) + (define done? #f) + (define t + (parameterize ([current-output-port stdout] + [current-error-port stderr] + [current-input-port stdin] + [current-command-line-arguments (list->vector args)]) + (thread + (lambda () + (when rt-p (dynamic-require rt-p d)) + (dynamic-require p d) + ((executable-yield-handler) 0) + (set! done? #t))))) + (unless (thread? (sync/timeout timeout t)) + (set! timeout? #t) + (error test-exe-name "timeout after ~a seconds" timeout)) + (unless done? + (error test-exe-name "test raised an exception")) + (define post (test-log #:display? #f #:exit? #f)) + (values 0 + (cons (- (car post) (car pre)) + (- (cdr post) (cdr pre))))] + [(place) + ;; Start the test place: + (define-values (pl in out/f err/f) + (parameterize ([current-custodian c]) + (dynamic-place* '(submod compiler/commands/test place) + 'go + #:in stdin + #:out stdout + #:err stderr))) + + ;; Send the module path to test: + (place-channel-put pl (list p rt-p d (current-directory) args)) + + ;; Wait for the place to finish: + (unless (sync/timeout timeout (place-dead-evt pl)) + (set! timeout? #t) + (error test-exe-name "timeout after ~a seconds" timeout)) + + ;; Get result code and test results: + (values (place-wait pl) + (sync/timeout 0 pl))] + [(process) + (define tmp-file (make-temporary-file)) + (define tmp-dir (and fresh-user? + (make-temporary-file "home~a" 'directory))) + (define ps + (parameterize ([current-output-port stdout] + [current-error-port stderr] + [current-subprocess-custodian-mode 'kill] + [current-custodian c] + [current-environment-variables (environment-variables-copy + (current-environment-variables))]) + (when fresh-user? + (environment-variables-set! (current-environment-variables) + #"PLTUSERHOME" + (path->bytes tmp-dir)) + (environment-variables-set! (current-environment-variables) + #"TMPDIR" + (path->bytes tmp-dir)) + (environment-variables-set! (current-environment-variables) + #"PLTADDONDIR" + (path->bytes (find-system-path 'addon-dir)))) + (apply process*/ports + stdout + stdin + stderr + (find-exe) + "-l" + "racket/base" + "-e" + "(dynamic-require '(submod compiler/commands/test process) #f)" + tmp-file + (format "~s" (normalize-module-path p)) + (format "~s" (normalize-module-path rt-p)) + (format "~s" d) + args))) + (define proc (list-ref ps 4)) + + (unless (sync/timeout timeout (thread (lambda () (proc 'wait)))) + (set! timeout? #t) + (error test-exe-name "timeout after ~a seconds" timeout)) + + (define results + (with-handlers ([exn:fail:read? (lambda () #f)]) + (call-with-input-file* tmp-file read))) + + (delete-file tmp-file) + (when tmp-dir + (delete-directory/files tmp-dir)) + + (values (proc 'exit-code) + (and (pair? results) + (exact-nonnegative-integer? (car results)) + (exact-nonnegative-integer? (cdr results)) + results))])) + + ;; Shut down the place/process (usually a no-op unless it timed out): + (custodian-shutdown-all c) + + ;; Check results: + (when check-stderr? + (unless (let ([s (get-output-bytes e)]) + (or (equal? #"" s) + (ormap (lambda (p) (regexp-match? p s)) + ignore-stderr-patterns))) + (parameterize ([error-print-width 16384]) + (error test-exe-name "non-empty stderr: ~e" (get-output-bytes e))))) + (unless (zero? result-code) + (error test-exe-name "non-zero exit: ~e" result-code)) + (cond + [test-results + (summary (car test-results) (cdr test-results) (current-label) #f 0)] + [else + (summary 0 1 (current-label) #f 0)])) + + ;; Serialize the above with a lock, if any: + (if lock-name + (call-with-file-lock/timeout + #:max-delay max-lock-delay + (build-path lock-file-dir lock-name) + 'exclusive + go + (lambda () (error test-exe-name "could not obtain lock: ~s" lock-name))) + (go)))) + +;; For recording stderr while also propagating to the original stderr: +(define (tee-output-port p1 p2) + (make-output-port + (object-name p1) + p1 + (lambda (bstr start end non-block? enable-break?) + (cond + [(= start end) + (flush-output p1) + 0] + [else + (define n (write-bytes-avail* bstr p1 start end)) + (cond + [(or (not n) + (zero? n)) + (wrap-evt p1 (lambda (v) 0))] + [else + (write-bytes bstr p2 start (+ start n)) + n])])) + (lambda () + (close-output-port p1) + (close-output-port p2)))) + +(define (extract-file-name p) + (cond + [(and (pair? p) (eq? 'submod (car p))) + (cadr p)] + [else p])) + +(define (add-submod mod sm) + (if (and (pair? mod) (eq? 'submod (car mod))) + (append mod '(config)) + (error test-exe-name "cannot add test-config submodule to path: ~s" mod))) + +(define (dynamic-require* p rt-p d + #:id id + #:try-config? try-config? + #:args args + #:timeout timeout + #:responsible responsible + #:lock-name lock-name + #:random? random?) + (define lookup + (or (cond + [(not try-config?) #f] + [(module-declared? (add-submod p 'config) #t) + (dynamic-require (add-submod p 'config) '#%info-lookup)] + [else #f]) + (lambda (what get-default) (get-default)))) + (dynamic-require-elsewhere + p rt-p d args + #:id id + #:responsible (lookup 'responsible + (lambda () responsible)) + #:timeout (if default-timeout + (lookup 'timeout + (lambda () timeout)) + +inf.0) + #:lock-name (lookup 'lock-name + (lambda () lock-name)) + #:random? (lookup 'random? + (lambda () random?)))) + +(define current-label (make-parameter "???")) +(struct summary (failed total label body-res timeout)) + +(define-syntax-rule (with-summary label . body) + (call-with-summary label (lambda () . body))) + +(define (call-with-summary label thunk) + (define res + ;; Produces either a summary or a list of summary: + (parameterize ([current-label label]) + (thunk))) + (if (summary? res) + res + (summary + (apply + (map summary-failed res)) + (apply + (map summary-total res)) + (current-label) + res + (apply + (map summary-timeout res))))) + + +(define (iprintf i fmt . more) + (for ([j (in-range i)]) + (display #\space)) + (apply printf fmt more)) +(define (display-summary top) + (define files + (let flatten ([sum top]) + (match sum + [(list sum ...) + (append-map flatten sum)] + [(summary failed total `(file ,p) body timeout) + (list sum)] + [(summary failed total label body timeout) + (flatten body)] + [(? void?) + empty]))) + (define sfiles + (sort files + (λ (x y) + (cond + [(= (summary-failed x) (summary-failed y)) + (> (summary-total x) (summary-total y))] + [else + (< (summary-failed x) (summary-failed y))])))) + (define (max-width f) + (string-length + (number->string + (apply max 0 (map f sfiles))))) + (define failed-wid (max-width summary-failed)) + (define total-wid (max-width summary-total)) + (for ([f (in-list sfiles)]) + (match-define (summary failed total `(file ,p) _ _) f) + (displayln (~a (~a #:min-width failed-wid + #:align 'right + (if (zero? failed) + "" + failed)) + " " + (~a #:min-width total-wid + #:align 'right + total) + " " p)))) + +;; Like `map`, but allows `run-one-test`s in parallel while starting +;; tasks in the order that a plain `map` would run them. The #:sema +;; argument everywhere makes tests start in a deterministic order +;; and keeps a filesystem traversal from getting far ahead of the +;; test runs. +(define (map/parallel f l #:sema continue-sema) + (cond + [(jobs . <= . 1) (map (lambda (v) (f v #:sema continue-sema)) l)] + [else + (struct task (th result-box)) + (define ts + (for/list ([i (in-list l)]) + (define b (box #f)) + (define c-sema (make-semaphore)) + (define t (thread + (lambda () + (set-box! b (with-handlers ([exn? values]) + (f i #:sema c-sema))) + ;; If no parallel task was ever created, + ;; count that as progress to the parent + ;; thread: + (semaphore-post c-sema)))) + (sync c-sema) + (task t b))) + (semaphore-post continue-sema) + (map sync (map task-th ts)) + (for/list ([t (in-list ts)]) + (define v (unbox (task-result-box t))) + (if (exn? v) + (raise v) + v))])) + +(define (normalize-module-path p) + (cond + [(path? p) (path->string p)] + [(and (pair? p) (eq? 'submod (car p))) + (list* 'submod (normalize-module-path (cadr p)) (cddr p))] + [else p])) + +(define ids '(1)) +(define ids-lock (make-semaphore 1)) + +(define (set-jobs! n) + (set! jobs n) + (set! task-sema (make-semaphore jobs)) + (set! ids (for/list ([i (in-range jobs)]) i))) + +;; Perform test of one module (in parallel, as allowed by +;; `task-sema`): +(define (test-module p mod rt-mod + #:sema continue-sema + #:try-config? try-config? + #:args [args '()] + #:timeout [timeout +inf.0] + #:responsible [responsible #f] + #:lock-name [lock-name #f] + #:random? [random? #f]) + (call-with-semaphore + task-sema ; limits parallelism + (lambda () + (semaphore-post continue-sema) ; allow next to try to start + (define id + (call-with-semaphore + ids-lock + (lambda () + (define id (car ids)) + (set! ids (cdr ids)) + (unless quiet? + ;; in lock, so printouts are not interleaved + (printf "raco test: ~a~s~a\n" + (if (jobs . <= . 1) + "" + (format "~a " id)) + (let ([m (normalize-module-path p)]) + (if (and (pair? mod) (eq? 'submod (car mod))) + (list* 'submod m (cddr mod)) + m)) + (apply string-append + (for/list ([a (in-list args)]) + (format " ~s" (format "~a" a))))) + (flush-output)) + id))) + (define heartbeat-sema (make-semaphore)) + (define heartbeat-t + (and heartbeat-secs + (thread (lambda () + (let loop () + (unless (sync/timeout heartbeat-secs heartbeat-sema) + (call-with-semaphore + ids-lock + (lambda () + (printf "raco test: ~a[still on ~s]\n" + (if (jobs . <= . 1) + "" + (format "~a " id)) + (let ([m (normalize-module-path p)]) + (if (and (pair? mod) (eq? 'submod (car mod))) + (list* 'submod m (cddr mod)) + m))))) + (loop))))))) + (begin0 + (dynamic-require* mod rt-mod 0 + #:id (if (jobs . <= . 1) + "" + (format " ~a" id)) + #:try-config? try-config? + #:args args + #:timeout timeout + #:responsible responsible + #:lock-name lock-name + #:random? random?) + (when heartbeat-t + (semaphore-post heartbeat-sema) + (sync heartbeat-t)) + (call-with-semaphore + ids-lock + (lambda () + (set! ids (cons id ids)))))))) + +;; Perform all tests in path `e`: +(define (test-files e + #:check-suffix? [check-suffix? #f] + #:sema continue-sema) + (match e + [(? string? s) + (test-files (string->path s) + #:check-suffix? check-suffix? + #:sema continue-sema)] + [(? path? p) + (cond + [(directory-exists? p) + (set! single-file? #f) + (define dir-p (path->directory-path p)) + (check-info dir-p) + (if (omit-path? dir-p) + (summary 0 0 #f null 0) + (with-summary + `(directory ,p) + (map/parallel + (λ (dp #:sema s) + (test-files (build-path p dp) + #:check-suffix? #t + #:sema s)) + (directory-list p) + #:sema continue-sema)))] + [(and (or (not check-suffix?) + (and (regexp-match? rx:default-suffixes p) + (not (regexp-match? #rx"^[.]" (file-name-from-path p)))) + (get-cmdline p #f #:check-info? #t) + (include-path? p #:check-info? #t)) + (or (not check-suffix?) + (not (omit-path? p #:check-info? #t)))) + (unless check-suffix? + ;; make sure "info.rkt" information is loaded: + (check-info p)) + (define norm-p (normalize-info-path p)) + (define args (get-cmdline norm-p)) + (define timeout (get-timeout norm-p)) + (define lock-name (get-lock-name norm-p)) + (define responsible (get-responsible norm-p)) + (define random? (get-random norm-p)) + (parameterize ([current-directory (let-values ([(base name dir?) (split-path p)]) + (if (path? base) + base + (current-directory)))]) + (define file-name (file-name-from-path p)) + (define (test-this-module mod rt-mod try-config?) + (test-module p mod rt-mod + #:try-config? try-config? + #:sema continue-sema + #:args args + #:timeout timeout + #:responsible responsible + #:lock-name lock-name + #:random? random?)) + (with-summary + `(file ,p) + (let ([something-wasnt-declared? #f] + [did-one? #f] + [rt-mod + (and configure-runtime + (let ([mod `(submod ,file-name configure-runtime)]) + (and (module-declared? mod #t) + mod)))]) + (filter + values + (append + (for/list ([submodule (in-list (if (null? submodules) + '(test) + (reverse submodules)))]) + (define mod `(submod ,file-name ,submodule)) + (cond + [(and did-one? first-avail?) + #f] + [(with-handlers ([exn:fail? + (lambda (exn) + ;; If there's an error, then try running + ;; this submodule to let the error show. + ;; Log a warning, just in case. + (log-warning "submodule load failed: ~s" + (exn-message exn)) + 'error)]) + (and (module-declared? mod #t) + 'ok)) + => (lambda (mode) + (set! did-one? #t) + (test-this-module mod rt-mod (eq? mode 'ok)))] + [else + (set! something-wasnt-declared? #t) + #f])) + (list + (and (and run-anyways? something-wasnt-declared?) + (test-this-module file-name rt-mod #f))))))))] + [else (summary 0 0 #f null 0)])])) + +(module paths racket/base + (require setup/link + racket/match + setup/collection-name + raco/command-name + racket/list) + + (define test-exe-name (string->symbol (short-program+command-name))) + + (struct col (name path) #:transparent) + + (define (get-linked file user? version?) + (define version-re + (and version? + (regexp-quote (version)))) + (append + (for/list ([c+p + (in-list + (links #:file file #:user? user? #:version-regexp version-re + #:with-path? #t))]) + (col (car c+p) + (cdr c+p))) + (for/list ([cp + (in-list + (links #:file file #:user? user? #:version-regexp version-re + #:root? #t))] + #:when (directory-exists? cp) + [collection (in-list (directory-list cp))] + #:when (directory-exists? (build-path cp collection))) + (col (path->string collection) + (build-path cp collection))))) + + ;; A list of `col's, where each collection may be represented + ;; by multiple elements of the list, each with its own path. + (define (all-collections) + (remove-duplicates + (append* + (for/list ([cp (current-library-collection-paths)] + #:when (directory-exists? cp) + [collection (in-list (directory-list cp))] + #:when (directory-exists? (build-path cp collection))) + (col (path->string collection) + (build-path cp collection))) + (for*/list ([file (in-list (current-library-collection-links))] + [user? (in-list '(#t #f))] + [version? (in-list '(#t #f))]) + (get-linked file user? version?))))) + + ;; This should be in Racket somewhere and return all the collection + ;; paths, rather than just the first as collection-path does. + (define (collection-paths c) + (when (not (collection-name? c)) + (error test-exe-name "not a collection name in: ~a" c)) + (match-define (list-rest sc more) (map path->string (explode-path c))) + (append* + (for/list ([col (all-collections)] + #:when (string=? sc (col-name col))) + (define p (col-path col)) + (define cp (apply build-path p more)) + (if (directory-exists? cp) + (list cp) + empty)))) + + (provide collection-paths)) + +(require (submod "." paths)) + +(define collections? #f) +(define packages? #f) +(define libraries? #f) +(define check-top-suffix? #f) + +(define (test-top e + #:check-suffix? check-suffix? + #:sema continue-sema) + (cond + [collections? + (match (collection-paths e) + [(list) + (error test-exe-name + (string-append "collection not found\n" + " collection name: ~a") + e)] + [l + (with-summary + `(collection ,e) + (map/parallel test-files l #:sema continue-sema))])] + [libraries? + (define (find x) + (define rmp ((current-module-name-resolver) x #f #f #f)) + (define p (resolved-module-path-name rmp)) + (and (file-exists? p) p)) + (match (find `(lib ,e)) + [#f + (error test-exe-name + (string-append "module not found\n" + " module path: ~a") + e)] + [l + (with-summary + `(library ,l) + (test-files l #:sema continue-sema))])] + [packages? + (define pd (pkg-directory e)) + (if pd + (with-summary + `(package ,e) + (test-files pd #:sema continue-sema)) + (error test-exe-name + (string-append "no such installed package\n" + " package name: ~a") + e))] + [else + (unless (or (file-exists? e) + (directory-exists? e)) + (error test-exe-name + (string-append "no such file or directory\n" + " path: ~a") + e)) + (test-files e + #:check-suffix? check-suffix? + #:sema continue-sema)])) + +;; -------------------------------------------------- +;; Reading "info.rkt" files + +(define omit-paths (make-hash)) +(define include-paths (make-hash)) +(define command-line-arguments (make-hash)) +(define timeouts (make-hash)) +(define lock-names (make-hash)) +(define responsibles (make-hash)) +(define randoms (make-hash)) + +(define pkg-cache (make-hash)) +(define collects-cache (make-hash)) +(define info-done (make-hash)) + +(define (check-dir-info p) + (define-values (base name dir?) (split-path p)) + (define dir (normalize-info-path + (if dir? + p + (if (path? base) + (path->complete-path base) + (current-directory))))) + + (unless (hash-ref info-done dir #f) + (hash-set! info-done dir #t) + (define info (get-info/full dir)) + (when info + (define (bad what v) + (log-error "bad `~a' in \"info.rkt\": ~e" what v)) + + (define (get-members table what all-ok?) + (define v (info what (lambda () '()))) + (cond + [(and all-ok? (eq? v 'all)) + (hash-set! table dir #t)] + [(list? v) + (for ([i (in-list v)]) + (cond + [(path-string? i) + (define p (normalize-info-path (path->complete-path i dir))) + (define dp (if (directory-exists? p) + (path->directory-path p) + p)) + (hash-set! table dp #t)] + [(regexp? i) + (for ([f (in-directory dir)] + #:when (regexp-match i (path->string f))) + (hash-set! table f #t))] + [else + (bad what v)]))] + [else (bad what v)])) + (get-members omit-paths 'test-omit-paths #t) + (get-members include-paths 'test-include-paths #t) + (get-members randoms 'test-randoms #t) + + (define (get-keyed table what check? #:ok-all? [ok-all? #f]) + (define a (info what (lambda () '()))) + (if (list? a) + (for ([arg (in-list a)]) + (unless (and (list? arg) + (= 2 (length arg)) + (or (path-string? (car arg)) + (and ok-all? + (eq? (car arg) 'all))) + (check? (cadr arg))) + (bad what a)) + (hash-set! table + (normalize-info-path (if (eq? (car arg) 'all) + dir + (path->complete-path (car arg) dir))) + (cadr arg))) + (bad what a))) + + (get-keyed command-line-arguments + 'test-command-line-arguments + (lambda (v) (and (list? v) + (andmap path-string? v)))) + (get-keyed timeouts + 'test-timeouts + (lambda (v) (real? v))) + (get-keyed lock-names + 'test-lock-names + (lambda (v) (or (not v) + (and (string? v) + (path-string? v))))) + (get-keyed responsibles + 'test-responsibles + ok-responsible? + #:ok-all? #t) + (get-keyed randoms + 'test-random + (lambda (v) (string? v)))))) + +(define (check-info/parents dir subpath) + (let loop ([dir dir] [subpath subpath]) + (check-dir-info dir) + (define-values (next-subpath subpath-name subpath-dir?) (split-path subpath)) + (define-values (next-dir dir-name dir-dir?) (split-path dir)) + (when (path? next-subpath) + (loop next-dir next-subpath)))) + +(define (check-info p) + (check-dir-info p) + ;; Check enclosing collection + (define-values (base name dir?) (split-path p)) + (define c (if dir? + #f + (path->collects-relative p #:cache collects-cache))) + (when (list? c) + (check-info/parents (if (path? base) + (path->complete-path base) + (current-directory)) ; got 'relative + (apply build-path (map bytes->path (reverse (cdr (reverse (cdr c))))))))) + +(define (normalize-info-path p) + (simplify-path (path->complete-path p) #f)) + +(define (make-omit-path? omit-paths) + (define (omit-path? p #:check-info? [check-info? #f]) + (when check-info? (check-info p)) + (let ([p (normalize-info-path p)]) + (or (hash-ref omit-paths p #f) + (let-values ([(base name dir?) (split-path p)]) + (and (path? base) + (omit-path? base)))))) + omit-path?) + +(define omit-path? (make-omit-path? omit-paths)) +(define include-path? (make-omit-path? include-paths)) + +(define (get-cmdline p [default null] #:check-info? [check-info? #f]) + (when check-info? (check-info p)) + (hash-ref command-line-arguments + (if check-info? (normalize-info-path p) p) + default)) + +(define (get-timeout p) + ;; assumes `(check-info p)` has been called and `p` is normalized + (hash-ref timeouts p (or default-timeout +inf.0))) + +(define (get-lock-name p) + ;; assumes `(check-info p)` has been called and `p` is normalized + (hash-ref lock-names p #f)) + +(define (get-responsible p) + ;; assumes `(check-info p)` has been called and `p` is normalized + (or (let loop ([p p]) + (or (hash-ref responsibles p #f) + (let-values ([(base name dir?) (split-path p)]) + (and (path? base) + (loop base))))) + ;; Check package authors: + (let-values ([(pkg subpath) (path->pkg+subpath p #:cache pkg-cache)]) + (and pkg + (let ([pkg-dir (if (path? subpath) + (apply build-path + (drop-right (explode-path p) + (length (explode-path subpath)))) + pkg)]) + (define info (get-info/full pkg-dir)) + (and info + (let ([v (info 'pkg-authors (lambda () #f))]) + (and (ok-responsible? v) + v)))))))) + +(define (get-random p) + ;; assumes `(check-info p)` has been called and `p` is normalized + (hash-ref randoms p #f)) + +(define (ok-responsible? v) + (or (string? v) + (symbol? v) + (and (list? v) + (andmap (lambda (v) (or (symbol? v) (string? v))) + v)))) + +;; -------------------------------------------------- + +(define (string->number* what s check) + (define n (string->number s)) + (unless (check n) + (raise-user-error (string->symbol (short-program+command-name)) + "invalid ~a: ~s" + what + s)) + n) + +(command-line + #:program (short-program+command-name) + #:once-any + [("--collection" "-c") + "Interpret arguments as collections" + (set! collections? #t)] + [("--lib" "-l") + "Interpret arguments as libraries" + (set! libraries? #t)] + [("--package" "-p") + "Interpret arguments as packages" + (set! packages? #t)] + [("--modules" "-m") + ("Interpret arguments as modules" + " (ignore argument unless \".rkt\", \".scrbl\", or enabled by \"info.rkt\")") + (set! check-top-suffix? #t)] + #:once-each + [("--drdr") + "Configure defaults to imitate DrDr" + (set! check-top-suffix? #t) + (set! first-avail? #t) + (set! empty-input? #t) + (when (zero? jobs) + (set-jobs! (processor-count))) + (unless default-timeout + (set! default-timeout 90)) + (set! check-stderr? #t) + (set! quiet-program? #t) + (set! fresh-user? #t) + (set! table? #t) + (unless default-mode + (set! default-mode 'process))] + #:multi + [("--submodule" "-s") name + "Runs submodule \n (defaults to running just the `test' submodule)" + (let ([n (string->symbol name)]) + (set! submodules (cons n submodules)))] + #:once-any + [("--run-if-absent" "-r") + "Require module if submodule is absent (on by default)" + (set! run-anyways? #t)] + [("--no-run-if-absent" "-x") + "Require nothing if submodule is absent" + (set! run-anyways? #f)] + #:once-each + [("--first-avail") + "Run only the first available submodule" + (set! first-avail? #f)] + [("--configure-runtime") + "Run the `configure-runtime' submodule" + (set! configure-runtime #t)] + #:once-any + [("--direct") + "Run tests directly (default for a single file)" + (set! default-mode 'direct)] + [("--process") + "Run tests in separate processes (default for multiple files)" + (set! default-mode 'process)] + [("--place") + "Run tests in places" + (set! default-mode 'place)] + #:once-each + [("--jobs" "-j") n + "Run up to tests in parallel" + (set-jobs! (string->number* "jobs" n exact-positive-integer?))] + [("--timeout") seconds + "Set default timeout to " + (set! default-timeout (string->number* "timeout" seconds real?))] + [("--fresh-user") + "Fresh PLTUSERHOME, etc., for each test" + (set! fresh-user? #t)] + [("--empty-stdin") + "Call program with an empty stdin" + (set! empty-input? #t)] + [("--quiet-program" "-Q") + "Quiet the program" + (set! quiet-program? #t)] + [("--check-stderr" "-e") + "Treat stderr output as a test failure" + (set! check-stderr? #t)] + #:multi + [("++ignore-stderr") pattern + "Ignore standard error output if it matches #px\"\"" + (set! ignore-stderr-patterns + (cons (pregexp pattern) ignore-stderr-patterns))] + #:once-each + [("--quiet" "-q") + "Suppress `raco test: ...' message" + (set! quiet? #t)] + [("--heartbeat") + "Periodically report that a test is still running" + (set! heartbeat-secs 5)] + [("--table" "-t") + "Print a summary table" + (set! table? #t)] + #:args file-or-directory + (begin (unless (= 1 (length file-or-directory)) + (set! single-file? #f)) + (when (and (eq? configure-runtime 'default) + (or (and (not single-file?) + (not (memq default-mode '(process place)))) + (not (null? submodules)))) + (set! configure-runtime #f)) + (define sum + ;; The #:sema argument everywhre makes tests start + ;; in a deterministic order: + (map/parallel (lambda (f #:sema s) + (test-top f + #:check-suffix? check-top-suffix? + #:sema s)) + file-or-directory + #:sema (make-semaphore))) + (when table? + (display-summary sum)) + (unless (or (eq? default-mode 'direct) + (and (not default-mode) single-file?)) + ;; Re-log failures and successes, and then report using `test-log`. + ;; (This is awkward; is it better to not try to use `test-log`?) + (for ([s (in-list sum)]) + (for ([i (in-range (summary-failed s))]) + (test-log! #f)) + (for ([i (in-range (- (summary-total s) + (summary-failed s)))]) + (test-log! #t)))) + (test-log #:display? #t #:exit? #f) + (define sum1 (call-with-summary #f (lambda () sum))) + (exit (cond + [(positive? (summary-timeout sum1)) 2] + [(positive? (summary-failed sum1)) 1] + [else 0])))) diff --git a/compiler-lib/compiler/commands/unpack.rkt b/compiler-lib/compiler/commands/unpack.rkt new file mode 100644 index 0000000000..2c2a1cfdd7 --- /dev/null +++ b/compiler-lib/compiler/commands/unpack.rkt @@ -0,0 +1,102 @@ +#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))) diff --git a/compiler-lib/compiler/compiler-unit.rkt b/compiler-lib/compiler/compiler-unit.rkt new file mode 100644 index 0000000000..4f6b768420 --- /dev/null +++ b/compiler-lib/compiler/compiler-unit.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(require compiler/compiler compiler/sig racket/unit) +(provide compiler@) +(define-unit-from-context compiler@ compiler^) \ No newline at end of file diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt new file mode 100644 index 0000000000..a393218fff --- /dev/null +++ b/compiler-lib/compiler/decompile.rkt @@ -0,0 +1,606 @@ +#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) + ' + (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))))) diff --git a/compiler-lib/compiler/demodularizer/alpha.rkt b/compiler-lib/compiler/demodularizer/alpha.rkt new file mode 100644 index 0000000000..63dc5508a8 --- /dev/null +++ b/compiler-lib/compiler/demodularizer/alpha.rkt @@ -0,0 +1,20 @@ +#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?)]) diff --git a/compiler-lib/compiler/demodularizer/batch.rkt b/compiler-lib/compiler/demodularizer/batch.rkt new file mode 100644 index 0000000000..456ded38e7 --- /dev/null +++ b/compiler-lib/compiler/demodularizer/batch.rkt @@ -0,0 +1,61 @@ +#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 from flattening" + (current-excluded-modules (set-add (current-excluded-modules) path))] + #:once-each + [("-o") dest-filename "Write output as " + (output-file (string->path dest-filename))] + [("-g" "--garbage-collect") "Garbage-collect final module (unsound)" + (garbage-collect-toplevels-enabled #t)] + #:args (filename) + (demodularize filename (output-file)))) + +(module test racket/base) diff --git a/compiler-lib/compiler/demodularizer/gc-toplevels.rkt b/compiler-lib/compiler/demodularizer/gc-toplevels.rkt new file mode 100644 index 0000000000..6f4987bd2d --- /dev/null +++ b/compiler-lib/compiler/demodularizer/gc-toplevels.rkt @@ -0,0 +1,288 @@ +#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?)]) diff --git a/compiler-lib/compiler/demodularizer/info.rkt b/compiler-lib/compiler/demodularizer/info.rkt new file mode 100644 index 0000000000..84ad0ac2d5 --- /dev/null +++ b/compiler-lib/compiler/demodularizer/info.rkt @@ -0,0 +1,3 @@ +#lang info + +(define test-responsibles '((all jay))) diff --git a/compiler-lib/compiler/demodularizer/main.rkt b/compiler-lib/compiler/demodularizer/main.rkt new file mode 100644 index 0000000000..b6fc0989a9 --- /dev/null +++ b/compiler-lib/compiler/demodularizer/main.rkt @@ -0,0 +1,77 @@ +#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 + demodularize) + +(define garbage-collect-toplevels-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)))) diff --git a/compiler-lib/compiler/demodularizer/merge.rkt b/compiler-lib/compiler/demodularizer/merge.rkt new file mode 100644 index 0000000000..fd7ddff67f --- /dev/null +++ b/compiler-lib/compiler/demodularizer/merge.rkt @@ -0,0 +1,229 @@ +#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?)]) diff --git a/compiler-lib/compiler/demodularizer/module.rkt b/compiler-lib/compiler/demodularizer/module.rkt new file mode 100644 index 0000000000..4f984c27af --- /dev/null +++ b/compiler-lib/compiler/demodularizer/module.rkt @@ -0,0 +1,43 @@ +#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?)]) diff --git a/compiler-lib/compiler/demodularizer/mpi.rkt b/compiler-lib/compiler/demodularizer/mpi.rkt new file mode 100644 index 0000000000..65c0b76ad7 --- /dev/null +++ b/compiler-lib/compiler/demodularizer/mpi.rkt @@ -0,0 +1,41 @@ +#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))]) diff --git a/compiler-lib/compiler/demodularizer/nodep.rkt b/compiler-lib/compiler/demodularizer/nodep.rkt new file mode 100644 index 0000000000..7d7bada6f1 --- /dev/null +++ b/compiler-lib/compiler/demodularizer/nodep.rkt @@ -0,0 +1,223 @@ +#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) + (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))]) diff --git a/compiler-lib/compiler/demodularizer/replace-modidx.rkt b/compiler-lib/compiler/demodularizer/replace-modidx.rkt new file mode 100644 index 0000000000..4cd6fc698a --- /dev/null +++ b/compiler-lib/compiler/demodularizer/replace-modidx.rkt @@ -0,0 +1,29 @@ +#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)) diff --git a/compiler-lib/compiler/demodularizer/update-toplevels.rkt b/compiler-lib/compiler/demodularizer/update-toplevels.rkt new file mode 100644 index 0000000000..c122511649 --- /dev/null +++ b/compiler-lib/compiler/demodularizer/update-toplevels.rkt @@ -0,0 +1,108 @@ +#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?))]) diff --git a/compiler-lib/compiler/demodularizer/util.rkt b/compiler-lib/compiler/demodularizer/util.rkt new file mode 100644 index 0000000000..e18966798e --- /dev/null +++ b/compiler-lib/compiler/demodularizer/util.rkt @@ -0,0 +1,79 @@ +#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)))]) diff --git a/compiler-lib/compiler/embed-sig.rkt b/compiler-lib/compiler/embed-sig.rkt new file mode 100644 index 0000000000..aeded68b62 --- /dev/null +++ b/compiler-lib/compiler/embed-sig.rkt @@ -0,0 +1,13 @@ + +(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))) diff --git a/compiler-lib/compiler/embed-unit.rkt b/compiler-lib/compiler/embed-unit.rkt new file mode 100644 index 0000000000..6361ca61cd --- /dev/null +++ b/compiler-lib/compiler/embed-unit.rkt @@ -0,0 +1,9 @@ +#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@) diff --git a/compiler-lib/compiler/option-unit.rkt b/compiler-lib/compiler/option-unit.rkt new file mode 100644 index 0000000000..c0f42328b5 --- /dev/null +++ b/compiler-lib/compiler/option-unit.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(require racket/unit compiler/sig compiler/option) + +(provide compiler:option@) + +(define-unit-from-context compiler:option@ compiler:option^) diff --git a/compiler-lib/compiler/sig.rkt b/compiler-lib/compiler/sig.rkt new file mode 100644 index 0000000000..87f1af4dda --- /dev/null +++ b/compiler-lib/compiler/sig.rkt @@ -0,0 +1,39 @@ +#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)) diff --git a/compiler-lib/info.rkt b/compiler-lib/info.rkt new file mode 100644 index 0000000000..cce80f1f4a --- /dev/null +++ b/compiler-lib/info.rkt @@ -0,0 +1,16 @@ +#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") diff --git a/compiler-lib/launcher/launcher-sig.rkt b/compiler-lib/launcher/launcher-sig.rkt new file mode 100644 index 0000000000..5554889de1 --- /dev/null +++ b/compiler-lib/launcher/launcher-sig.rkt @@ -0,0 +1,57 @@ +#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 diff --git a/compiler-lib/launcher/launcher-unit.rkt b/compiler-lib/launcher/launcher-unit.rkt new file mode 100644 index 0000000000..165362229c --- /dev/null +++ b/compiler-lib/launcher/launcher-unit.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(require racket/unit "launcher-sig.rkt" launcher/launcher) + +(provide launcher@) + +(define-unit-from-context launcher@ launcher^) diff --git a/compiler-lib/setup/option-sig.rkt b/compiler-lib/setup/option-sig.rkt new file mode 100644 index 0000000000..5308450163 --- /dev/null +++ b/compiler-lib/setup/option-sig.rkt @@ -0,0 +1,37 @@ +(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))) diff --git a/compiler-lib/setup/option-unit.rkt b/compiler-lib/setup/option-unit.rkt new file mode 100644 index 0000000000..1b36be3f1d --- /dev/null +++ b/compiler-lib/setup/option-unit.rkt @@ -0,0 +1,6 @@ +#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^) \ No newline at end of file diff --git a/compiler-lib/setup/setup-unit.rkt b/compiler-lib/setup/setup-unit.rkt new file mode 100644 index 0000000000..addfd12088 --- /dev/null +++ b/compiler-lib/setup/setup-unit.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +(require racket/unit setup/setup-core) + +(provide setup@) +(define-unit setup@ + (import) + (export) + (setup-core)) diff --git a/compiler-test/LICENSE.txt b/compiler-test/LICENSE.txt new file mode 100644 index 0000000000..bf291935db --- /dev/null +++ b/compiler-test/LICENSE.txt @@ -0,0 +1,11 @@ +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. diff --git a/compiler-test/info.rkt b/compiler-test/info.rkt new file mode 100644 index 0000000000..a39c4d12de --- /dev/null +++ b/compiler-test/info.rkt @@ -0,0 +1,20 @@ +#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")) diff --git a/compiler-test/tests/compiler/collection-zos.rkt b/compiler-test/tests/compiler/collection-zos.rkt new file mode 100644 index 0000000000..f74074d856 --- /dev/null +++ b/compiler-test/tests/compiler/collection-zos.rkt @@ -0,0 +1,5 @@ +#lang racket +(require compiler/compiler) + +;; minimal sanity check: +(compile-collection-zos "setup") diff --git a/compiler-test/tests/compiler/commands/test.rkt b/compiler-test/tests/compiler/commands/test.rkt new file mode 100644 index 0000000000..62dbe1dbc7 --- /dev/null +++ b/compiler-test/tests/compiler/commands/test.rkt @@ -0,0 +1,5 @@ +#lang racket +(require rackunit) +(require (only-in (submod compiler/commands/test paths) collection-paths)) + +(check-exn exn? (lambda () (collection-paths "."))) diff --git a/compiler-test/tests/compiler/ctool.rkt b/compiler-test/tests/compiler/ctool.rkt new file mode 100644 index 0000000000..32c2e36907 --- /dev/null +++ b/compiler-test/tests/compiler/ctool.rkt @@ -0,0 +1,19 @@ +#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) diff --git a/compiler-test/tests/compiler/demodularizer/demod-test.rkt b/compiler-test/tests/compiler/demodularizer/demod-test.rkt new file mode 100644 index 0000000000..0fd5b24fa8 --- /dev/null +++ b/compiler-test/tests/compiler/demodularizer/demod-test.rkt @@ -0,0 +1,53 @@ +#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))))) diff --git a/compiler-test/tests/compiler/demodularizer/info.rkt b/compiler-test/tests/compiler/demodularizer/info.rkt new file mode 100644 index 0000000000..355d8e262d --- /dev/null +++ b/compiler-test/tests/compiler/demodularizer/info.rkt @@ -0,0 +1,3 @@ +#lang info + +(define test-timeouts '(("demod-test.rkt" 300))) diff --git a/compiler-test/tests/compiler/demodularizer/tests/base-5.rkt b/compiler-test/tests/compiler/demodularizer/tests/base-5.rkt new file mode 100644 index 0000000000..ea2c5d0f5e --- /dev/null +++ b/compiler-test/tests/compiler/demodularizer/tests/base-5.rkt @@ -0,0 +1,2 @@ +#lang racket/base +5 diff --git a/compiler-test/tests/compiler/demodularizer/tests/kernel-5.rkt b/compiler-test/tests/compiler/demodularizer/tests/kernel-5.rkt new file mode 100644 index 0000000000..9b75f464c6 --- /dev/null +++ b/compiler-test/tests/compiler/demodularizer/tests/kernel-5.rkt @@ -0,0 +1,5 @@ +(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))) diff --git a/compiler-test/tests/compiler/demodularizer/tests/racket-5.rkt b/compiler-test/tests/compiler/demodularizer/tests/racket-5.rkt new file mode 100644 index 0000000000..e4d92af6b9 --- /dev/null +++ b/compiler-test/tests/compiler/demodularizer/tests/racket-5.rkt @@ -0,0 +1,2 @@ +#lang racket +5 diff --git a/compiler-test/tests/compiler/embed/embed-asl.rkt b/compiler-test/tests/compiler/embed/embed-asl.rkt new file mode 100644 index 0000000000..14a2c20866 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-asl.rkt @@ -0,0 +1,4 @@ +;; 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 diff --git a/compiler-test/tests/compiler/embed/embed-bsl.rkt b/compiler-test/tests/compiler/embed/embed-bsl.rkt new file mode 100644 index 0000000000..2c8819a72f --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-bsl.rkt @@ -0,0 +1,4 @@ +;; 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 diff --git a/compiler-test/tests/compiler/embed/embed-bsla.rkt b/compiler-test/tests/compiler/embed/embed-bsla.rkt new file mode 100644 index 0000000000..a8382c3bd6 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-bsla.rkt @@ -0,0 +1,4 @@ +;; 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 diff --git a/compiler-test/tests/compiler/embed/embed-isl.rkt b/compiler-test/tests/compiler/embed/embed-isl.rkt new file mode 100644 index 0000000000..ef27ea6de6 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-isl.rkt @@ -0,0 +1,4 @@ +;; 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 diff --git a/compiler-test/tests/compiler/embed/embed-isll.rkt b/compiler-test/tests/compiler/embed/embed-isll.rkt new file mode 100644 index 0000000000..225485a486 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-isll.rkt @@ -0,0 +1,4 @@ +;; 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 diff --git a/compiler-test/tests/compiler/embed/embed-me1.rkt b/compiler-test/tests/compiler/embed/embed-me1.rkt new file mode 100644 index 0000000000..c7cf7b2bfb --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me1.rkt @@ -0,0 +1,5 @@ +(module embed-me1 mzscheme + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") + (lambda () (printf "This is 1\n")) + 'append)) + diff --git a/compiler-test/tests/compiler/embed/embed-me10.rkt b/compiler-test/tests/compiler/embed/embed-me10.rkt new file mode 100644 index 0000000000..7ba6b48b13 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me10.rkt @@ -0,0 +1,9 @@ +(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)) + + diff --git a/compiler-test/tests/compiler/embed/embed-me11-rd.rkt b/compiler-test/tests/compiler/embed/embed-me11-rd.rkt new file mode 100644 index 0000000000..ad91d873e7 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me11-rd.rkt @@ -0,0 +1,15 @@ +(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))) diff --git a/compiler-test/tests/compiler/embed/embed-me11.rkt b/compiler-test/tests/compiler/embed/embed-me11.rkt new file mode 100644 index 0000000000..105f4033ea --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me11.rkt @@ -0,0 +1,2 @@ +#reader(lib "embed-me11-rd.ss" "tests" "compiler" "embed") +"It goes to ~a!\n" diff --git a/compiler-test/tests/compiler/embed/embed-me12-rd.ss b/compiler-test/tests/compiler/embed/embed-me12-rd.ss new file mode 100644 index 0000000000..ad91d873e7 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me12-rd.ss @@ -0,0 +1,15 @@ +(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))) diff --git a/compiler-test/tests/compiler/embed/embed-me12.ss b/compiler-test/tests/compiler/embed/embed-me12.ss new file mode 100644 index 0000000000..b1d4610954 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me12.ss @@ -0,0 +1,2 @@ +#reader(lib "embed-me12-rd.rkt" "tests" "compiler" "embed") +"It goes to ~a!\n" diff --git a/compiler-test/tests/compiler/embed/embed-me13.rkt b/compiler-test/tests/compiler/embed/embed-me13.rkt new file mode 100644 index 0000000000..a29c30b53e --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me13.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(require racket/runtime-path) +(define-runtime-module-path-index _mod "embed-me14.rkt") +(dynamic-require _mod #f) diff --git a/compiler-test/tests/compiler/embed/embed-me14.rkt b/compiler-test/tests/compiler/embed/embed-me14.rkt new file mode 100644 index 0000000000..21987b423f --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me14.rkt @@ -0,0 +1,5 @@ +#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) diff --git a/compiler-test/tests/compiler/embed/embed-me15-one.rkt b/compiler-test/tests/compiler/embed/embed-me15-one.rkt new file mode 100644 index 0000000000..c1df6af344 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me15-one.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(define two 2) +(provide two) + +(module* one #f + (require (submod "." ".." three)) + (define one 1) + (provide one two three)) + +(module three racket/base + (define three 3) + (provide three)) + diff --git a/compiler-test/tests/compiler/embed/embed-me15.rkt b/compiler-test/tests/compiler/embed/embed-me15.rkt new file mode 100644 index 0000000000..ebd9f5d9c9 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me15.rkt @@ -0,0 +1,5 @@ +#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) diff --git a/compiler-test/tests/compiler/embed/embed-me16.rkt b/compiler-test/tests/compiler/embed/embed-me16.rkt new file mode 100644 index 0000000000..6bb9de67b3 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me16.rkt @@ -0,0 +1,7 @@ +#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)) diff --git a/compiler-test/tests/compiler/embed/embed-me17.rkt b/compiler-test/tests/compiler/embed/embed-me17.rkt new file mode 100644 index 0000000000..ecac985e4a --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me17.rkt @@ -0,0 +1,2 @@ +#lang racket/base +(require (submod "embed-me17a.rkt" sub)) diff --git a/compiler-test/tests/compiler/embed/embed-me17a.rkt b/compiler-test/tests/compiler/embed/embed-me17a.rkt new file mode 100644 index 0000000000..6f61620ea8 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me17a.rkt @@ -0,0 +1,9 @@ +#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)) diff --git a/compiler-test/tests/compiler/embed/embed-me18.rkt b/compiler-test/tests/compiler/embed/embed-me18.rkt new file mode 100644 index 0000000000..b8fd250173 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me18.rkt @@ -0,0 +1,5 @@ +#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) diff --git a/compiler-test/tests/compiler/embed/embed-me18a.rkt b/compiler-test/tests/compiler/embed/embed-me18a.rkt new file mode 100644 index 0000000000..107e3fedd2 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me18a.rkt @@ -0,0 +1,9 @@ +#lang racket/base +(module sub racket/base + (provide print-18) + (define (print-18) + (printf "This is 18.\n"))) + + + + \ No newline at end of file diff --git a/compiler-test/tests/compiler/embed/embed-me19.rkt b/compiler-test/tests/compiler/embed/embed-me19.rkt new file mode 100644 index 0000000000..addc967a4e --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me19.rkt @@ -0,0 +1,14 @@ +#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) diff --git a/compiler-test/tests/compiler/embed/embed-me1b.rkt b/compiler-test/tests/compiler/embed/embed-me1b.rkt new file mode 100644 index 0000000000..6344f44446 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me1b.rkt @@ -0,0 +1,9 @@ +#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) + diff --git a/compiler-test/tests/compiler/embed/embed-me1c.rkt b/compiler-test/tests/compiler/embed/embed-me1c.rkt new file mode 100644 index 0000000000..d08dd0b4ee --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me1c.rkt @@ -0,0 +1,9 @@ +#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) + diff --git a/compiler-test/tests/compiler/embed/embed-me1d.rkt b/compiler-test/tests/compiler/embed/embed-me1d.rkt new file mode 100644 index 0000000000..3847ca2c43 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me1d.rkt @@ -0,0 +1,8 @@ +#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) diff --git a/compiler-test/tests/compiler/embed/embed-me1e.rkt b/compiler-test/tests/compiler/embed/embed-me1e.rkt new file mode 100644 index 0000000000..1942a29e6f --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me1e.rkt @@ -0,0 +1,8 @@ +#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) diff --git a/compiler-test/tests/compiler/embed/embed-me1f.rkt b/compiler-test/tests/compiler/embed/embed-me1f.rkt new file mode 100644 index 0000000000..ef2d99ed30 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me1f.rkt @@ -0,0 +1,12 @@ +#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) diff --git a/compiler-test/tests/compiler/embed/embed-me1f1.rktl b/compiler-test/tests/compiler/embed/embed-me1f1.rktl new file mode 100644 index 0000000000..5e2940e678 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me1f1.rktl @@ -0,0 +1 @@ +(load-relative "sub/embed-me1f2.rktl") diff --git a/compiler-test/tests/compiler/embed/embed-me2.rkt b/compiler-test/tests/compiler/embed/embed-me2.rkt new file mode 100644 index 0000000000..232c0a8c4d --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me2.rkt @@ -0,0 +1,6 @@ +(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)) diff --git a/compiler-test/tests/compiler/embed/embed-me20.rkt b/compiler-test/tests/compiler/embed/embed-me20.rkt new file mode 100644 index 0000000000..f0851e8134 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me20.rkt @@ -0,0 +1,7 @@ +#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)) diff --git a/compiler-test/tests/compiler/embed/embed-me21.rkt b/compiler-test/tests/compiler/embed/embed-me21.rkt new file mode 100644 index 0000000000..856fd11230 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me21.rkt @@ -0,0 +1,12 @@ +#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)]) diff --git a/compiler-test/tests/compiler/embed/embed-me22.rkt b/compiler-test/tests/compiler/embed/embed-me22.rkt new file mode 100644 index 0000000000..729a45a171 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me22.rkt @@ -0,0 +1,6 @@ +#lang racket/kernel + +(printf "This is 22.\n") + +(module configure-runtime racket/kernel + (printf "Configure!\n")) diff --git a/compiler-test/tests/compiler/embed/embed-me23.rkt b/compiler-test/tests/compiler/embed/embed-me23.rkt new file mode 100644 index 0000000000..2f6eb92c10 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me23.rkt @@ -0,0 +1,8 @@ +#lang racket/base +(require racket/serialize) + +(serializable-struct foo (a b)) + +(define f (deserialize (serialize (foo 1 2)))) +(foo-a f) +(foo-b f) diff --git a/compiler-test/tests/compiler/embed/embed-me24.rkt b/compiler-test/tests/compiler/embed/embed-me24.rkt new file mode 100644 index 0000000000..974da5b6fe --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me24.rkt @@ -0,0 +1,3 @@ +#lang racket + +"Ok" diff --git a/compiler-test/tests/compiler/embed/embed-me25.rkt b/compiler-test/tests/compiler/embed/embed-me25.rkt new file mode 100644 index 0000000000..59d7f600a9 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me25.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +(module+ main + 12) + +(module submod racket/base + 11) + +10 diff --git a/compiler-test/tests/compiler/embed/embed-me26.rkt b/compiler-test/tests/compiler/embed/embed-me26.rkt new file mode 100644 index 0000000000..979fe8ec32 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me26.rkt @@ -0,0 +1,10 @@ +#lang racket/base + +(module+ main + 12) + +(module submod racket/base + 11) + +10 +(require (submod "embed-me27.rkt" other-submod)) diff --git a/compiler-test/tests/compiler/embed/embed-me27.rkt b/compiler-test/tests/compiler/embed/embed-me27.rkt new file mode 100644 index 0000000000..6db0fbf611 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me27.rkt @@ -0,0 +1,3 @@ +#lang racket/base + +(module+ other-submod 'y) diff --git a/compiler-test/tests/compiler/embed/embed-me28.rkt b/compiler-test/tests/compiler/embed/embed-me28.rkt new file mode 100644 index 0000000000..426a4aa503 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me28.rkt @@ -0,0 +1,14 @@ +#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)) diff --git a/compiler-test/tests/compiler/embed/embed-me29-2.rkt b/compiler-test/tests/compiler/embed/embed-me29-2.rkt new file mode 100644 index 0000000000..28be26231b --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me29-2.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(module inside racket/base + (define inside 'inside) + (provide inside)) diff --git a/compiler-test/tests/compiler/embed/embed-me29.rkt b/compiler-test/tests/compiler/embed/embed-me29.rkt new file mode 100644 index 0000000000..be6b4c3a3e --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me29.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(module main racket/base + (require (submod "embed-me29-2.rkt" inside)) + inside) diff --git a/compiler-test/tests/compiler/embed/embed-me3.rkt b/compiler-test/tests/compiler/embed/embed-me3.rkt new file mode 100644 index 0000000000..d34cde4dc6 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me3.rkt @@ -0,0 +1,7 @@ +(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)) + diff --git a/compiler-test/tests/compiler/embed/embed-me4.rktl b/compiler-test/tests/compiler/embed/embed-me4.rktl new file mode 100644 index 0000000000..24e22b0787 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me4.rktl @@ -0,0 +1,4 @@ +(with-output-to-file "stdout" + (lambda () (printf "This is the literal expression 4.\n")) + 'append) + diff --git a/compiler-test/tests/compiler/embed/embed-me5.rkt b/compiler-test/tests/compiler/embed/embed-me5.rkt new file mode 100644 index 0000000000..f78a77d77a --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me5.rkt @@ -0,0 +1,6 @@ +(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)) + diff --git a/compiler-test/tests/compiler/embed/embed-me6.rkt b/compiler-test/tests/compiler/embed/embed-me6.rkt new file mode 100644 index 0000000000..8cc774ae89 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me6.rkt @@ -0,0 +1,8 @@ +(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)) + diff --git a/compiler-test/tests/compiler/embed/embed-me6b.rkt b/compiler-test/tests/compiler/embed/embed-me6b.rkt new file mode 100644 index 0000000000..c2643bf99b --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me6b.rkt @@ -0,0 +1,8 @@ +(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)) + diff --git a/compiler-test/tests/compiler/embed/embed-me8.c b/compiler-test/tests/compiler/embed/embed-me8.c new file mode 100644 index 0000000000..c4fda30513 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me8.c @@ -0,0 +1,31 @@ +#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"); +} diff --git a/compiler-test/tests/compiler/embed/embed-me9.rkt b/compiler-test/tests/compiler/embed/embed-me9.rkt new file mode 100644 index 0000000000..f9aabb24b5 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me9.rkt @@ -0,0 +1,9 @@ +(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)) + diff --git a/compiler-test/tests/compiler/embed/embed-place.rkt b/compiler-test/tests/compiler/embed/embed-place.rkt new file mode 100644 index 0000000000..46e33a7483 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-place.rkt @@ -0,0 +1,7 @@ +#lang racket/base +(require racket/place) + +(provide go) + +(define (go ch) + (place-channel-put ch 42)) diff --git a/compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt b/compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt new file mode 100644 index 0000000000..68008701f7 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "main.rkt") + +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") + #:exists 'append + (lambda () (displayln "alt"))) diff --git a/compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt b/compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt new file mode 100644 index 0000000000..e3f8034168 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt @@ -0,0 +1,8 @@ +#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)))) diff --git a/compiler-test/tests/compiler/embed/embed-planet-1/has-sub.rkt b/compiler-test/tests/compiler/embed/embed-planet-1/has-sub.rkt new file mode 100644 index 0000000000..e2f1bb7de1 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-planet-1/has-sub.rkt @@ -0,0 +1,6 @@ +#lang racket/base + +(module+ the-sub + (provide out) + (define out 'out)) + diff --git a/compiler-test/tests/compiler/embed/embed-planet-1/main.rkt b/compiler-test/tests/compiler/embed/embed-planet-1/main.rkt new file mode 100644 index 0000000000..550c457847 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-planet-1/main.rkt @@ -0,0 +1,4 @@ +#lang racket/base + +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") + (lambda () (displayln "one"))) diff --git a/compiler-test/tests/compiler/embed/embed-planet-1/other.rkt b/compiler-test/tests/compiler/embed/embed-planet-1/other.rkt new file mode 100644 index 0000000000..d05dfbd3d8 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-planet-1/other.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require (planet racket-tester/p2)) + +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") + #:exists 'append + (lambda () (displayln "other"))) diff --git a/compiler-test/tests/compiler/embed/embed-planet-2/main.ss b/compiler-test/tests/compiler/embed/embed-planet-2/main.ss new file mode 100644 index 0000000000..6874861598 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-planet-2/main.ss @@ -0,0 +1,5 @@ +#lang racket/base + + +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") + (lambda () (displayln "two"))) diff --git a/compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt b/compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt new file mode 100644 index 0000000000..24ff5d4162 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "../main.ss") + +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") + #:exists 'append + (lambda () (displayln "sub"))) diff --git a/compiler-test/tests/compiler/embed/info.rkt b/compiler-test/tests/compiler/embed/info.rkt new file mode 100644 index 0000000000..618b4d7f48 --- /dev/null +++ b/compiler-test/tests/compiler/embed/info.rkt @@ -0,0 +1,22 @@ +#lang info + +(define compile-omit-paths '("embed-me9.rkt" + "embed-planet-1" + + ;; Could be compiled, but we skep them to avoid + ;; dependencies. This needs to be cleaned up. + "embed-me5.rkt" + "embed-me19.rkt" + "embed-bsl.rkt" + "embed-bsla.rkt" + "embed-isl.rkt" + "embed-isll.rkt" + "embed-asl.rkt")) + +(define test-omit-paths '("embed-me9.rkt" + "embed-planet-1" + "embed-planet-2")) + +(define test-timeouts '(("test.rkt" 900))) + +(define test-responsibles '((all mflatt))) diff --git a/compiler-test/tests/compiler/embed/sub/embed-me1f2.rktl b/compiler-test/tests/compiler/embed/sub/embed-me1f2.rktl new file mode 100644 index 0000000000..a70455650f --- /dev/null +++ b/compiler-test/tests/compiler/embed/sub/embed-me1f2.rktl @@ -0,0 +1 @@ +(printf "This is 1f\n") diff --git a/compiler-test/tests/compiler/embed/test.rkt b/compiler-test/tests/compiler/embed/test.rkt new file mode 100644 index 0000000000..2659443059 --- /dev/null +++ b/compiler-test/tests/compiler/embed/test.rkt @@ -0,0 +1,695 @@ +#lang racket/base + +(require compiler/embed + racket/file + racket/system + racket/port + launcher + compiler/distribute + (only-in pkg/lib installed-pkg-names)) + +(define (test expect f/label . args) + (define r (apply (if (procedure? f/label) + f/label + values) + args)) + (unless (equal? expect r) + (error "failed\n"))) + +(define (mk-dest-bin mred?) + (case (system-type) + [(windows) "e.exe"] + [(unix) "e"] + [(macosx) (if mred? + "e.app" + "e")])) + +(define (mk-dest mred?) + (build-path (find-system-path 'temp-dir) + (mk-dest-bin mred?))) + +(define mz-dest (mk-dest #f)) +(define mr-dest (mk-dest #t)) + +(define dist-dir (build-path (find-system-path 'temp-dir) + "e-dist")) +(define dist-mz-exe (build-path + (case (system-type) + [(windows) 'same] + [else "bin"]) + (mk-dest-bin #f))) +(define dist-mred-exe (build-path + (case (system-type) + [(windows macosx) 'same] + [else "bin"]) + (mk-dest-bin #t))) + +(define (prepare exe src) + (printf "Making ~a with ~a...\n" exe src) + (when (file-exists? exe) + (delete-file exe))) + +(define (try-one-exe exe expect mred?) + (printf "Running ~a\n" exe) + (let ([plthome (getenv "PLTHOME")] + [collects (getenv "PLTCOLLECTS")] + [out (open-output-string)]) + (define temp-home-dir (make-temporary-file "racket-tmp-home~a" 'directory)) + ;; Try to hide usual collections: + (parameterize ([current-environment-variables + (environment-variables-copy + (current-environment-variables))]) + (putenv "PLTUSERHOME" (path->string temp-home-dir)) + (when plthome + (putenv "PLTHOME" (path->string (build-path (find-system-path 'temp-dir) "NOPE")))) + (when collects + (putenv "PLTCOLLECTS" (path->string (build-path (find-system-path 'temp-dir) "NOPE")))) + ;; Execute: + (parameterize ([current-directory (find-system-path 'temp-dir)]) + (when (file-exists? "stdout") + (delete-file "stdout")) + (let ([path (if (and mred? (eq? 'macosx (system-type))) + (let-values ([(base name dir?) (split-path exe)]) + (build-path exe "Contents" "MacOS" + (path-replace-suffix name #""))) + exe)]) + (test #t + path + (parameterize ([current-output-port out]) + (system* path)))))) + (delete-directory/files temp-home-dir) + (let ([stdout-file (build-path (find-system-path 'temp-dir) "stdout")]) + (if (file-exists? stdout-file) + (test expect with-input-from-file stdout-file + (lambda () (read-string 5000))) + (test expect get-output-string out))))) + +(define (try-exe exe expect mred? [dist-hook void] #:dist? [dist? #t] . collects) + (try-one-exe exe expect mred?) + (when dist? + ;; Build a distribution directory, and try that, too: + (printf " ... from distribution ...\n") + (when (directory-exists? dist-dir) + (delete-directory/files dist-dir)) + (assemble-distribution dist-dir (list exe) #:copy-collects collects) + (dist-hook) + (try-one-exe (build-path dist-dir + (if mred? + dist-mred-exe + dist-mz-exe)) + expect mred?) + (delete-directory/files dist-dir))) + +(define (base-compile e) + (parameterize ([current-namespace (make-base-namespace)]) + (compile e))) +(define (kernel-compile e) + (parameterize ([current-namespace (make-base-empty-namespace)]) + (namespace-require ''#%kernel) + (compile e))) + +(define (mz-tests mred?) + (define dest (if mred? mr-dest mz-dest)) + (define (flags s) + (string-append "-" s)) + (define (one-mz-test filename expect literal?) + ;; Try simple mode: one module, launched from cmd line: + (prepare dest filename) + (make-embedding-executable + dest mred? #f + `((#t (lib ,filename "tests" "compiler" "embed"))) + null + #f + `(,(flags "l") ,(string-append "tests/compiler/embed/" filename))) + (try-exe dest expect mred?) + + ;; As a launcher: + (prepare dest filename) + ((if mred? make-gracket-launcher make-racket-launcher) + (list "-l" (string-append "tests/compiler/embed/" filename)) + dest) + (try-exe dest expect mred? #:dist? #f) + + ;; Try explicit prefix: + (printf ">>>explicit prefix\n") + (let ([w/prefix + (lambda (pfx) + (prepare dest filename) + (make-embedding-executable + dest mred? #f + `((,pfx (lib ,filename "tests" "compiler" "embed")) + (#t (lib "scheme/init"))) + null + #f + `(,(flags "lne") + "scheme/base" + ,(format "(require '~a~a)" + (or pfx "") + (regexp-replace #rx"[.].*$" filename "")))) + (try-exe dest expect mred?))]) + (w/prefix #f) + (w/prefix 'before:)) + + (when literal? + ;; Try full path, and use literal S-exp to start + (printf ">>>literal sexp\n") + (prepare dest filename) + (let ([path (build-path (collection-path "tests" "compiler" "embed") filename)]) + (make-embedding-executable + dest mred? #f + `((#t ,path)) + null + (base-compile + `(namespace-require '(file ,(path->string path)))) + `(,(flags "")))) + (try-exe dest expect mred?) + + ;; Use `file' form: + (printf ">>>file\n") + (prepare dest filename) + (let ([path (build-path (collection-path "tests" "compiler" "embed") filename)]) + (make-embedding-executable + dest mred? #f + `((#t (file ,(path->string path)))) + null + (base-compile + `(namespace-require '(file ,(path->string path)))) + `(,(flags "")))) + (try-exe dest expect mred?) + + ;; Use relative path + (printf ">>>relative path\n") + (prepare dest filename) + (parameterize ([current-directory (collection-path "tests" "compiler" "embed")]) + (make-embedding-executable + dest mred? #f + `((#f ,filename)) + null + (base-compile + `(namespace-require '',(string->symbol (regexp-replace #rx"[.].*$" filename "")))) + `(,(flags "")))) + (try-exe dest expect mred?) + + ;; Try multiple modules + (printf ">>>multiple\n") + (prepare dest filename) + (make-embedding-executable + dest mred? #f + `((#t (lib ,filename "tests" "compiler" "embed")) + (#t (lib "embed-me3.rkt" "tests" "compiler" "embed"))) + null + (base-compile + `(begin + (namespace-require '(lib "embed-me3.rkt" "tests" "compiler" "embed")) + (namespace-require '(lib ,filename "tests" "compiler" "embed")))) + `(,(flags ""))) + (try-exe dest (string-append "3 is here, too? #t\n" expect) mred?) + + ;; Try a literal file + (printf ">>>literal\n") + (prepare dest filename) + (let ([tmp (make-temporary-file)]) + (with-output-to-file tmp + #:exists 'truncate + (lambda () + (write (kernel-compile + '(namespace-require ''#%kernel))))) + (make-embedding-executable + dest mred? #f + `((#t (lib ,filename "tests" "compiler" "embed"))) + (list + tmp + (build-path (collection-path "tests" "compiler" "embed") "embed-me4.rktl")) + `(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") + (lambda () (display "... and more!\n")) + 'append) + `(,(flags "l") ,(string-append "tests/compiler/embed/" filename))) + (delete-file tmp)) + (try-exe dest (string-append + "This is the literal expression 4.\n" + "... and more!\n" + expect) + mred?))) + + (one-mz-test "embed-me1.rkt" "This is 1\n" #t) + (unless mred? + (one-mz-test "embed-me1b.rkt" "This is 1b\n" #f) + (one-mz-test "embed-me1c.rkt" "This is 1c\n" #f) + (one-mz-test "embed-me1d.rkt" "This is 1d\n" #f) + (one-mz-test "embed-me1e.rkt" "This is 1e\n" #f) + (one-mz-test "embed-me1f.rkt" "This is 1f\n" #f) + (one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t) + (one-mz-test "embed-me13.rkt" "This is 14\n" #f) + (one-mz-test "embed-me14.rkt" "This is 14\n" #f) + (one-mz-test "embed-me15.rkt" "This is 15.\n" #f) + (one-mz-test "embed-me17.rkt" "This is 17.\n" #f) + (one-mz-test "embed-me18.rkt" "This is 18.\n" #f) + (one-mz-test "embed-me19.rkt" "This is 19.\n" #f) + (one-mz-test "embed-me21.rkt" "This is 21.\n" #f)) + + ;; Try unicode expr and cmdline: + (prepare dest "unicode") + (make-embedding-executable + dest mred? #f + '((#t scheme/base)) + null + (base-compile + '(begin + (require scheme/base) + (eval '(define (out s) + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") + (lambda () (printf s)) + #:exists 'append))) + (out "\uA9, \u7238, and \U1D670\n"))) + `(,(flags "ne") "(out \"\u7237...\U1D671\n\")")) + (try-exe dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n" mred?)) + +(define (try-basic) + (mz-tests #f) + (mz-tests #t) + (begin + (prepare mr-dest "embed-me5.rkt") + (make-embedding-executable + mr-dest #t #f + `((#t (lib "embed-me5.rkt" "tests" "compiler" "embed"))) + null + #f + `("-l" "tests/compiler/embed/embed-me5.rkt")) + (try-exe mr-dest "This is 5: #\n" #t))) + +;; Try the raco interface: +(require setup/dirs + mzlib/file) +(define mzc (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) + "mzc.exe" + "mzc"))) +(define raco (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) + "raco.exe" + "raco"))) + +(define (system+ . args) + (printf "> ~a\n" (car (reverse args))) + (apply system* args)) + +(define (short-mzc-tests mred?) + (parameterize ([current-directory (find-system-path 'temp-dir)]) + + ;; raco exe + (system+ raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) + (try-exe (mk-dest mred?) "This is 1\n" mred?) + + ;; raco exe on a module with a `main' submodule + (system+ raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me16.rkt"))) + (try-exe (mk-dest mred?) "This is 16.\n" mred?))) + +(define (mzc-tests mred?) + (short-mzc-tests mred?) + (parameterize ([current-directory (find-system-path 'temp-dir)]) + + ;; raco exe + (system+ raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) + (try-exe (mk-dest mred?) "This is 1\n" mred?) + + ;; raco exe on a module with a `main' submodule + (system+ raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me16.rkt"))) + (try-exe (mk-dest mred?) "This is 16.\n" mred?) + + ;; raco exe on a module with a `main' submodule+ + (system+ raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me20.rkt"))) + (try-exe (mk-dest mred?) "This is 20.\n" mred?) + + ;; raco exe on a module with a `configure-runtime' submodule + (system+ raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me29.rkt"))) + (try-exe (mk-dest mred?) "'inside\n" mred?) + + ;; raco exe on a module with a submodule that references another file's submodule + (system+ raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me22.rkt"))) + (try-exe (mk-dest mred?) "Configure!\nThis is 22.\n" mred?) + + ;; raco exe on a module with serialization + (system+ raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me23.rkt"))) + (try-exe (mk-dest mred?) "1\n2\n" mred?) + + ;; raco exe on a module with `place` + (system+ raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me28.rkt"))) + (try-exe (mk-dest mred?) "28\n" mred?) + + ;; raco exe --launcher + (system+ raco + "exe" + "--launcher" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) + (try-exe (mk-dest mred?) "This is 1\n" mred? #:dist? #f) + + ;; the rest use mzc... + + (system+ mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) + (try-exe (mk-dest mred?) "This is 1\n" mred?) + + (define (check-collection-path prog lib in-main?) + ;; Check that etc.rkt isn't found if it's not included: + (printf ">>not included\n") + (system+ mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) + (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) + + ;; And it is found if it is included: + (printf ">>included\n") + (system+ mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + "++lib" lib + (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) + (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) + + ;; Or, it's found if we set the collection path: + (printf ">>set coll path\n") + (system+ mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + "--collects-path" + (path->string (find-collects-dir)) + (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) + ;; Don't try a distribution for this one: + (try-one-exe (mk-dest mred?) (if in-main? "This is 6\n#t\n" "This is 6\nno etc.ss\n") mred?) + + ;; Or, it's found if we set the collection path and the config path (where the latter + ;; finds links for packages): + (printf ">>set coll path plus config\n") + (system+ mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + "--collects-path" + (path->string (find-collects-dir)) + "--config-path" + (path->string (find-config-dir)) + (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) + ;; Don't try a distribution for this one: + (try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?) + + ;; Try --collects-dest mode + (printf ">>--collects-dest\n") + (system+ mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + "++lib" lib + "--collects-dest" "cts" + "--collects-path" "cts" + (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) + (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution + (delete-directory/files "cts") + (parameterize ([current-error-port (open-output-nowhere)]) + (test #f system+ (mk-dest mred?)))) + (check-collection-path "embed-me6b.rkt" "racket/fixnum.rkt" #t) + (check-collection-path "embed-me6.rkt" "mzlib/etc.rkt" + ;; "mzlib" is found via the "collects" path + ;; if it is accessible via the default + ;; collection-links configuration, which is + ;; essentially the same as being in installation + ;; scope: + (member "compatibility-lib" + (installed-pkg-names #:scope 'installation))) + + (void))) + +(define (try-mzc) + (mzc-tests #f) + (short-mzc-tests #t)) + +(require dynext/file) +(define (extension-test mred?) + (parameterize ([current-directory (find-system-path 'temp-dir)]) + + (define obj-file + (build-path (find-system-path 'temp-dir) (append-object-suffix "embed-me8"))) + + (define ext-base-dir + (build-path (find-system-path 'temp-dir) + "compiled")) + + (define ext-dir + (build-path ext-base-dir + "native" + (system-library-subpath))) + + (define ext-file + (build-path ext-dir (append-extension-suffix "embed-me8_rkt"))) + + (define ss-file + (build-path (find-system-path 'temp-dir) "embed-me9.rkt")) + + (make-directory* ext-dir) + + (system+ mzc + "--cc" + "-d" (path->string (path-only obj-file)) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me8.c"))) + (system+ mzc + "--ld" + (path->string ext-file) + (path->string obj-file)) + + (when (file-exists? ss-file) + (delete-file ss-file)) + (copy-file (build-path (collection-path "tests" "compiler" "embed") "embed-me9.rkt") + ss-file) + + (system+ mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + (path->string ss-file)) + + (delete-file ss-file) + + (try-exe (mk-dest mred?) "Hello, world!\n" mred? (lambda () + (delete-directory/files ext-base-dir))) + + ;; openssl, which needs extra binaries under Windows + (system+ mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me10.rkt"))) + (try-exe (mk-dest mred?) "#t\n" mred?))) + +(define (try-extension) + (extension-test #f) + (extension-test #t)) + +(define (try-gracket) + ;; A GRacket-specific test with mzc: + (parameterize ([current-directory (find-system-path 'temp-dir)]) + (system+ mzc + "--gui-exe" + (path->string (mk-dest #t)) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me5.rkt"))) + (try-exe (mk-dest #t) "This is 5: #\n" #t))) + +;; Try including source that needs a reader extension + +(define (try-reader-test 12? mred? ss-file? ss-reader?) + ;; actual "11" files use ".rkt", actual "12" files use ".ss" + (define dest (mk-dest mred?)) + (define filename (format (if ss-file? + "embed-me~a.ss" + "embed-me~a.rkt") + (if 12? "12" "11"))) + (define (flags s) + (string-append "-" s)) + + (printf "Trying ~s ~s ~s ~s...\n" (if 12? "12" "11") mred? ss-file? ss-reader?) + + (create-embedding-executable + dest + #:modules `((#t (lib ,filename "tests" "compiler" "embed"))) + #:cmdline `(,(flags "l") ,(string-append "tests/compiler/embed/" filename)) + #:src-filter (lambda (f) + (let-values ([(base name dir?) (split-path f)]) + (equal? name (path-replace-suffix (string->path filename) + (if 12? #".ss" #".rkt"))))) + #:get-extra-imports (lambda (f code) + (let-values ([(base name dir?) (split-path f)]) + (if (equal? name (path-replace-suffix (string->path filename) + (if 12? #".ss" #".rkt"))) + `((lib ,(format (if ss-reader? + "embed-me~a-rd.ss" + "embed-me~a-rd.rkt") + (if 12? "12" "11")) + "tests" + "compiler" + "embed")) + null))) + #:mred? mred?) + + (putenv "ELEVEN" "eleven") + (try-exe dest "It goes to eleven!\n" mred?) + (putenv "ELEVEN" "done")) + +(define (try-reader) + (for ([12? (in-list '(#f #t))]) + (try-reader-test 12? #f #f #f) + (try-reader-test 12? #t #f #f) + (try-reader-test 12? #f #t #f) + (try-reader-test 12? #f #f #t))) + +;; ---------------------------------------- + +(define (try-source) + (define (try-one file submod start result) + (define mred? #f) + (define dest (mk-dest mred?)) + + (printf "> ~a ~s from source\n" file submod) + (create-embedding-executable + dest + #:modules `((#%mzc: ,(collection-file-path file "tests/compiler/embed") ,submod)) + #:configure-via-first-module? #t + #:literal-expression + (parameterize ([current-namespace (make-base-namespace)]) + (compile + `(begin + (namespace-require ',start)))) + #:src-filter (lambda (p) (or (equal? p (collection-file-path "embed-me25.rkt" "tests/compiler/embed")) + (equal? p (collection-file-path "embed-me26.rkt" "tests/compiler/embed")) + (equal? p (collection-file-path "embed-me27.rkt" "tests/compiler/embed")))) + #:get-extra-imports (lambda (src mod) + (list 'racket/base/lang/reader))) + + (try-exe dest result mred?)) + + (try-one "embed-me25.rkt" null ''|#%mzc:embed-me25| "10\n") + (try-one "embed-me25.rkt" '(main) '(submod '|#%mzc:embed-me25| main) "10\n12\n") + (try-one "embed-me25.rkt" '(submod) '(submod '|#%mzc:embed-me25| submod) "11\n") + (try-one "embed-me26.rkt" null ''|#%mzc:embed-me26| "'y\n10\n") + (try-one "embed-me26.rkt" '(submod) '(submod '|#%mzc:embed-me26| submod) "11\n") + (try-one "embed-me26.rkt" '(main) '(submod '|#%mzc:embed-me26| main) "'y\n10\n12\n")) + +;; ---------------------------------------- + +(define planet (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) + "planet.exe" + "planet"))) + +(define (try-planet) + (system+ raco "planet" "link" "racket-tester" "p1.plt" "1" "0" + (path->string (collection-path "tests" "compiler" "embed" "embed-planet-1"))) + (system+ raco "planet" "link" "racket-tester" "p2.plt" "2" "2" + (path->string (collection-path "tests" "compiler" "embed" "embed-planet-2"))) + + (let ([go (lambda (path expected) + (printf "Trying planet ~s...\n" path) + (let ([tmp (make-temporary-file)] + [dest (mk-dest #f)]) + (with-output-to-file tmp + #:exists 'truncate + (lambda () + (printf "#lang racket/base (require ~s)\n" path))) + (system+ mzc "--exe" (path->string dest) (path->string tmp)) + (try-exe dest expected #f) + + (delete-directory/files dest) + + (delete-file tmp)))]) + (go '(planet racket-tester/p1) "one\n") + (go '(planet "racket-tester/p1:1") "one\n") + (go '(planet "racket-tester/p1:1:0") "one\n") + (go '(planet "racket-tester/p1:1:0/main.ss") "one\n") + (go '(planet racket-tester/p2) "two\n") + + (go '(planet racket-tester/p1/alt) "one\nalt\n") + (go '(planet racket-tester/p1/other) "two\nother\n") + (go '(planet "private/sub.rkt" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") + (go '(planet "private/sub.ss" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") + (go '(planet "main.ss" ("racket-tester" "p2.plt" 2 0)) "two\n") + + (go '(planet racket-tester/p1/dyn-sub) "out\n") + + (void)) + + (system+ raco "planet" "unlink" "racket-tester" "p1.plt" "1" "0") + (system+ raco "planet" "unlink" "racket-tester" "p2.plt" "2" "2")) + +;; ---------------------------------------- + +(define (try-*sl) + (define (try-one src) + (printf "Trying ~a...\n" src) + (define exe (path->string (mk-dest #f))) + (system+ raco + "exe" + "-o" exe + "--" + (path->string (build-path (collection-path "tests" "compiler" "embed") src))) + (try-exe exe "10\n" #f)) + + (try-one "embed-bsl.rkt") + (try-one "embed-bsla.rkt") + (try-one "embed-isl.rkt") + (try-one "embed-isll.rkt") + (try-one "embed-asl.rkt")) + +;; ---------------------------------------- + +(try-basic) +(try-mzc) +(try-extension) +(try-gracket) +(try-reader) +(try-planet) +(try-*sl) +(try-source) + +;; ---------------------------------------- +;; Make sure that embedding does not break future module declarations + +(let () + (parameterize ([current-output-port (open-output-bytes)]) + (write-module-bundle + #:modules (list (list #f (collection-file-path "embed-me24.rkt" "tests" "compiler" "embed"))))) + + (parameterize ([read-accept-reader #t] + [current-namespace (make-base-namespace)]) + (eval (read (open-input-string "#lang racket 10"))))) + diff --git a/compiler-test/tests/compiler/info.rkt b/compiler-test/tests/compiler/info.rkt new file mode 100644 index 0000000000..84ad0ac2d5 --- /dev/null +++ b/compiler-test/tests/compiler/info.rkt @@ -0,0 +1,3 @@ +#lang info + +(define test-responsibles '((all jay))) diff --git a/compiler-test/tests/compiler/make.rkt b/compiler-test/tests/compiler/make.rkt new file mode 100644 index 0000000000..d17d16cbb8 --- /dev/null +++ b/compiler-test/tests/compiler/make.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require racket/file + racket/path + racket/system + compiler/find-exe) + +(parameterize ((current-directory (find-system-path 'temp-dir))) + (define tmpdir (make-temporary-file "tmp~a" 'directory (current-directory))) + (define tmppath (build-path tmpdir "tmp.rkt")) + (with-output-to-file (build-path tmpdir "tmp.rkt") #:exists 'replace + (lambda () + (printf "#lang racket\n"))) + (define exec-path (find-exe)) + (define relpath (find-relative-path (current-directory) tmppath)) + + (define ok? (system* exec-path "-l" "raco" "make" "-j" "2" (path->string relpath))) + (delete-directory/files tmpdir) + + (unless ok? + (error "`raco make` test failed"))) diff --git a/compiler-test/tests/compiler/regression.rkt b/compiler-test/tests/compiler/regression.rkt new file mode 100644 index 0000000000..4e6e8825ff --- /dev/null +++ b/compiler-test/tests/compiler/regression.rkt @@ -0,0 +1,17 @@ +#lang scheme +(require net/cookie + tests/eli-tester) + +(define (set-when-true fn val) + (if val + (λ (c) (fn c val)) + (λ (c) c))) + +(define (make-cookie name val) + ((lambda (x) + ((set-when-true cookie:add-comment #f) + x)) + (set-cookie name val))) + +(test + (cookie? (make-cookie "name" "value"))) diff --git a/compiler-test/tests/compiler/test/a.rkt b/compiler-test/tests/compiler/test/a.rkt new file mode 100644 index 0000000000..a8b4a5e6f7 --- /dev/null +++ b/compiler-test/tests/compiler/test/a.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(error 'dont-run) +(module test racket/base + (printf "a\n")) diff --git a/compiler-test/tests/compiler/test/b.rkt b/compiler-test/tests/compiler/test/b.rkt new file mode 100644 index 0000000000..dc1a6edb80 --- /dev/null +++ b/compiler-test/tests/compiler/test/b.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(error 'dont-run) +(module test racket/base + (printf "b\n")) diff --git a/compiler-test/tests/compiler/test/d/.ignored.rkt b/compiler-test/tests/compiler/test/d/.ignored.rkt new file mode 100644 index 0000000000..1cc00a2f23 --- /dev/null +++ b/compiler-test/tests/compiler/test/d/.ignored.rkt @@ -0,0 +1,2 @@ +#lang racket/base +(error 'ignored "I shouldn't run!") diff --git a/compiler-test/tests/compiler/test/d/c.rkt b/compiler-test/tests/compiler/test/d/c.rkt new file mode 100644 index 0000000000..892e318617 --- /dev/null +++ b/compiler-test/tests/compiler/test/d/c.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(error 'dont-run) +(module test racket/base + (printf "c\n")) diff --git a/compiler-test/tests/compiler/test/d/d.rkt b/compiler-test/tests/compiler/test/d/d.rkt new file mode 100644 index 0000000000..7bc35af1c4 --- /dev/null +++ b/compiler-test/tests/compiler/test/d/d.rkt @@ -0,0 +1 @@ +#lang racket/base diff --git a/compiler-test/tests/compiler/test/extensions/a-omit-1.racket-file b/compiler-test/tests/compiler/test/extensions/a-omit-1.racket-file new file mode 100644 index 0000000000..46347b55a1 --- /dev/null +++ b/compiler-test/tests/compiler/test/extensions/a-omit-1.racket-file @@ -0,0 +1,4 @@ +#lang racket/base +(error 'bad) +(module+ test + (error 'bad)) diff --git a/compiler-test/tests/compiler/test/extensions/a-omit-1.rkt b/compiler-test/tests/compiler/test/extensions/a-omit-1.rkt new file mode 100644 index 0000000000..46347b55a1 --- /dev/null +++ b/compiler-test/tests/compiler/test/extensions/a-omit-1.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(error 'bad) +(module+ test + (error 'bad)) diff --git a/compiler-test/tests/compiler/test/extensions/b-include-1.racket-file b/compiler-test/tests/compiler/test/extensions/b-include-1.racket-file new file mode 100644 index 0000000000..5e2f56f1f0 --- /dev/null +++ b/compiler-test/tests/compiler/test/extensions/b-include-1.racket-file @@ -0,0 +1,5 @@ +#lang racket/base +(define (f x) x) +(module+ test + (require rackunit) + (check-equal? (f 1) 1)) diff --git a/compiler-test/tests/compiler/test/extensions/b-include-1.rkt b/compiler-test/tests/compiler/test/extensions/b-include-1.rkt new file mode 100644 index 0000000000..5e2f56f1f0 --- /dev/null +++ b/compiler-test/tests/compiler/test/extensions/b-include-1.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(define (f x) x) +(module+ test + (require rackunit) + (check-equal? (f 1) 1)) diff --git a/compiler-test/tests/compiler/test/extensions/info.rkt b/compiler-test/tests/compiler/test/extensions/info.rkt new file mode 100644 index 0000000000..c7f196c63d --- /dev/null +++ b/compiler-test/tests/compiler/test/extensions/info.rkt @@ -0,0 +1,3 @@ +#lang info +(define test-omit-paths '(#rx".*omit.*[.](rkt|racket-file)$")) +(define test-include-paths '(#rx".*include.*[.](rkt|racket-file)$")) diff --git a/compiler-test/tests/compiler/test/racket.rkt b/compiler-test/tests/compiler/test/racket.rkt new file mode 100644 index 0000000000..e0938ceaf3 --- /dev/null +++ b/compiler-test/tests/compiler/test/racket.rkt @@ -0,0 +1,2 @@ +#lang racket/base +(list 1 2) diff --git a/compiler-test/tests/compiler/test/runtime.rkt b/compiler-test/tests/compiler/test/runtime.rkt new file mode 100644 index 0000000000..5ecc70bb90 --- /dev/null +++ b/compiler-test/tests/compiler/test/runtime.rkt @@ -0,0 +1,29 @@ +#lang racket/base +(require racket/system + compiler/find-exe) + +(define exe (find-exe)) + +(define (try mode mod expect) + (printf "trying ~s ~s\n" mod mode) + (define s (open-output-bytes)) + (parameterize ([current-output-port s]) + (system* exe "-l-" "raco" "test" + mode "-l" (string-append "tests/compiler/test/" mod))) + (define last-line + (for/fold ([prev #f]) ([s (in-lines (open-input-bytes (get-output-bytes s)))]) + (if (or (eof-object? s) + (equal? s "1 test passed")) + prev + s))) + (unless (equal? expect last-line) + (error 'runtime "test failed\n module: ~s\n expected: ~s\n got: ~s" + mod expect last-line))) + +(for ([mod '("--direct" "--place" "--process")]) + (try mod "racket.rkt" "'(1 2)") + (try mod "scheme.rkt" "(1 2)")) + + + + diff --git a/compiler-test/tests/compiler/test/scheme.rkt b/compiler-test/tests/compiler/test/scheme.rkt new file mode 100644 index 0000000000..d2245f7c50 --- /dev/null +++ b/compiler-test/tests/compiler/test/scheme.rkt @@ -0,0 +1,2 @@ +#lang scheme/base +(list 1 2) diff --git a/compiler-test/tests/compiler/zo-exs.rkt b/compiler-test/tests/compiler/zo-exs.rkt new file mode 100644 index 0000000000..90a025c951 --- /dev/null +++ b/compiler-test/tests/compiler/zo-exs.rkt @@ -0,0 +1,125 @@ +#lang racket +(require compiler/zo-parse + compiler/zo-marshal + tests/eli-tester) + +(define (read-compiled-bytes bs) + (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes bs)))) + +(define (run-compiled-bytes bs [delayed? #t]) + (system "touch test.rkt") + (system "touch compiled/test_rkt.zo") + (system (format "racket ~a -t test.rkt" (if delayed? "" "-d")))) + +(define (roundtrip ct) + (define bs (zo-marshal ct)) + (test #:failure-prefix (format "~S" ct) + (test bs + (zo-parse (open-input-bytes bs)) => ct + (read-compiled-bytes bs) + #;(with-output-to-file "compiled/test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) + #;(run-compiled-bytes bs #t) + #;(run-compiled-bytes bs #f)))) + +(define mpi (module-path-index-join #f #f)) + + +(test + (roundtrip + (compilation-top 0 + #hash() + (prefix 0 empty empty 'insp0) + (list 1 (list 2 3) (list 2 3) 4 5))) + + (roundtrip + (compilation-top 0 + #hash() + (prefix 1 empty empty 'insp0) + (list (lam 'proc null 0 null #f #(0) '(val/ref) (set 0) 3 1)))) + (roundtrip + (compilation-top 0 + #hash() + (prefix 1 empty empty 'insp0) + (list (lam 'proc null 0 null #f #(0) '(val/ref) #f 3 1)))) + + #;(roundtrip + (compilation-top 0 + #hash() + (prefix 0 empty empty) + (let* ([ph (make-placeholder #f)] + [x (closure + (lam 'name + empty + 0 + empty + #f + #() + empty + 0 + ph) + 'name)]) + (placeholder-set! ph x) + (make-reader-graph x)))) + + ; This should work, but module-path-index-join doesn't create equal? module-path-index's + #;(roundtrip + (compilation-top + 0 + #hash() + (prefix 0 (list #f) (list)) + (mod + 'simple + 'simple + (module-path-index-join #f #f) + (prefix + 0 + (list (module-variable + (module-path-index-join + "modbeg.rkt" + (module-path-index-join + "pre-base.rkt" + (module-path-index-join + "namespace.rkt" + (module-path-index-join "private/base.rkt" (module-path-index-join 'racket/base #f))))) 'print-values 0 0)) + (list)) + (list) + (list (list 0 (module-path-index-join 'racket/base #f)) (list 1) (list -1) (list #f)) + (list (apply-values + (toplevel 0 0 #f #t) + (application + (primval 231) + (list 1 'a)))) + (list) + (list (list) (list) (list)) + 2 + (toplevel 0 0 #f #f) + #(racket/language-info get-info #f) + #t))) + + (roundtrip + (compilation-top 0 + #hash() + (prefix 0 empty empty 'insp0) + (current-directory))) + + (roundtrip + (compilation-top 0 + #hash() + (prefix 0 empty empty 'insp0) + (list (current-directory)))) + + (roundtrip + (compilation-top + 0 + #hash() + (prefix 0 empty empty 'insp0) + (cons #hash() + #hash()))) + + (roundtrip + (compilation-top + 0 + #hash() + (prefix 0 empty empty 'insp0) + #hash()))) diff --git a/compiler-test/tests/compiler/zo-test-util.rkt b/compiler-test/tests/compiler/zo-test-util.rkt new file mode 100644 index 0000000000..95dbc1c85b --- /dev/null +++ b/compiler-test/tests/compiler/zo-test-util.rkt @@ -0,0 +1,12 @@ +#lang racket + +(struct result (phase) #:prefab) +(struct failure result (serious? msg) #:prefab) +(struct success result () #:prefab) + +(provide/contract + [struct result ([phase symbol?])] + [struct failure ([phase symbol?] + [serious? boolean?] + [msg string?])] + [struct success ([phase symbol?])]) diff --git a/compiler-test/tests/compiler/zo-test-worker.rkt b/compiler-test/tests/compiler/zo-test-worker.rkt new file mode 100644 index 0000000000..416616f8e7 --- /dev/null +++ b/compiler-test/tests/compiler/zo-test-worker.rkt @@ -0,0 +1,272 @@ +#lang racket/base +(require racket/cmdline + compiler/zo-parse + compiler/zo-marshal + compiler/decompile + racket/port + racket/bool + racket/list + racket/match + "zo-test-util.rkt") + +(define (bytes-gulp f) + (with-input-from-file f + (λ () (port->bytes (current-input-port))))) + +(define (read-compiled-bytes bs) + (define ib (open-input-bytes bs)) + (dynamic-wind void + (lambda () + (parameterize ([read-accept-compiled #t]) + (read ib))) + (lambda () + (close-input-port ib)))) + +(define (zo-parse/bytes bs) + (define ib (open-input-bytes bs)) + (dynamic-wind void + (lambda () + (zo-parse ib)) + (lambda () + (close-input-port ib)))) + +(define (bytes-not-equal?-error b1 b2) + (unless (bytes=? b1 b2) + (error 'bytes-not-equal?-error "Not equal"))) + +(define (replace-file file bytes) + (with-output-to-file file + (λ () (write-bytes bytes)) + #:exists 'truncate)) + +(define (equal?/why-not v1 v2) + (define v1->v2 (make-hasheq)) + (define (interned-symbol=? s1 s2) + (symbol=? (hash-ref! v1->v2 s1 s2) s2)) + (define (yield p m v1 v2) + (error 'equal?/why-not "~a in ~a: ~S ~S" + m (reverse p) v1 v2)) + (define (inner p v1 v2) + (unless (eq? v1 v2) + (match v1 + [(cons car1 cdr1) + (match v2 + [(cons car2 cdr2) + (inner (list* 'car p) car1 car2) + (inner (list* 'cdr p) cdr1 cdr2)] + [_ + (yield p "Not a cons on right" v1 v2)])] + [(? vector?) + (match v2 + [(? vector?) + (define v1l (vector-length v1)) + (define v2l (vector-length v2)) + (if (= v1l v2l) + (for ([i (in-range v1l)]) + (inner (list* `(vector-ref ,i) p) + (vector-ref v1 i) + (vector-ref v2 i))) + (yield p "Vector lengths not equal" v1 v2))] + [_ + (yield p "Not a vector on right" v1 v2)])] + [(? struct?) + (match v2 + [(? struct?) + (define vv1 (struct->vector v1)) + (define vv2 (struct->vector v2)) + (inner (list* `(struct->vector ,(vector-ref vv1 0)) p) + vv1 vv2)] + [_ + (yield p "Not a struct on right" v1 v2)])] + [(? hash?) + (match v2 + [(? hash?) + (let ([p (list* 'in-hash p)]) + (for ([(k1 hv1) (in-hash v1)]) + (define hv2 + (hash-ref v2 k1 + (lambda () + (yield p (format "~S not in hash on right" k1) v1 v2)))) + (inner (list* `(hash-ref ,k1) p) + hv1 hv2)))] + [_ + (yield p "Not a hash on right" v1 v2)])] + [(? module-path-index?) + (match v2 + [(? module-path-index?) + (define-values (mp1 bmpi1) (module-path-index-split v1)) + (define-values (mp2 bmpi2) (module-path-index-split v2)) + (inner (list* 'module-path-index-split_0 p) mp1 mp2) + (inner (list* 'module-path-index-split_1 p) bmpi1 bmpi2)] + [_ + (yield p "Not a module path index on right" v1 v2)])] + [(? string?) + (match v2 + [(? string?) + (unless (string=? v1 v2) + (yield p "Unequal strings" v1 v2))] + [_ + (yield p "Not a string on right" v1 v2)])] + [(? bytes?) + (match v2 + [(? bytes?) + (unless (bytes=? v1 v2) + (yield p "Unequal bytes" v1 v2))] + [_ + (yield p "Not a bytes on right" v1 v2)])] + [(? path?) + (match v2 + [(? path?) + (unless (equal? v1 v2) + (yield p "Unequal paths" v1 v2))] + [_ + (yield p "Not a path on right" v1 v2)])] + [(? number?) + (match v2 + [(? number?) + (unless (equal? v1 v2) + (yield p "Unequal numbers" v1 v2))] + [_ + (yield p "Not a number on right" v1 v2)])] + [(? regexp?) + (match v2 + [(? regexp?) + (unless (string=? (object-name v1) (object-name v2)) + (yield p "Unequal regexp" v1 v2))] + [_ + (yield p "Not a regexp on right" v1 v2)])] + [(? byte-regexp?) + (match v2 + [(? byte-regexp?) + (unless (bytes=? (object-name v1) (object-name v2)) + (yield p "Unequal byte-regexp" v1 v2))] + [_ + (yield p "Not a byte-regexp on right" v1 v2)])] + [(? box?) + (match v2 + [(? box?) + (inner (list* 'unbox) (unbox v1) (unbox v2))] + [_ + (yield p "Not a box on right" v1 v2)])] + [(? symbol?) + (match v2 + [(? symbol?) + (unless (symbol=? v1 v2) + (cond + [(and (symbol-interned? v1) (not (symbol-interned? v1))) + (yield p "Not interned symbol on right" v1 v2)] + [(and (symbol-unreadable? v1) (not (symbol-unreadable? v1))) + (yield p "Not unreadable symbol on right" v1 v2)] + [(and (symbol-uninterned? v1) (not (symbol-uninterned? v1))) + (yield p "Not uninterned symbol on right" v1 v2)] + [(and (symbol-uninterned? v1) (symbol-uninterned? v2)) + (unless (interned-symbol=? v1 v2) + (yield p "Uninterned symbols don't align" v1 v2))] + [else + (yield p "Other symbol-related problem" v1 v2)]))] + [_ + (yield p "Not a symbol on right" v1 v2)])] + [(? empty?) + (yield p "Not empty on right" v1 v2)] + [_ + (yield p "Cannot inspect values deeper" v1 v2)]))) + (inner empty v1 v2)) + +(define (symbol-uninterned? s) + (not (or (symbol-interned? s) (symbol-unreadable? s)))) + +(define (run-with-limit file k thnk) + (define file-custodian (make-custodian)) + (define ch (make-channel)) + (custodian-limit-memory file-custodian k) + (define worker-thread + (parameterize ([current-custodian file-custodian]) + (thread + (lambda () + (define r (thnk)) + (channel-put ch r) + (channel-get ch))))) + (begin0 + (sync + (handle-evt ch + (lambda (v) + (when (exn? v) (raise v)) + v)) + (handle-evt worker-thread + (lambda _ + (record! (failure 'memory #f "Over memory limit"))))) + (custodian-shutdown-all file-custodian))) + +(define-syntax run/stages* + (syntax-rules () + [(_ file) + (record! (success 'everything))] + [(_ file [step1 serious? e] . rst) + (let/ec esc + (let ([step1 (with-handlers ([exn:fail? + (lambda (x) + (record! (failure 'step1 serious? + (exn-message x))) + (if serious? + (esc #f) + #f))]) + (begin0 e + (record! (success 'step1))))]) + (run/stages* file . rst)))])) + +(define-syntax-rule (define-stages (run! file) + [stage serious? e] ...) + (define (run! file) + (run/stages* file [stage serious? e] ...))) + +(define-stages (run! file) + [read-orig + #t + (bytes-gulp file)] + [parse-orig + #t + (zo-parse/bytes read-orig)] + [marshal-parsed + #t + (zo-marshal parse-orig)] + [parse-marshaled + #t + (zo-parse/bytes marshal-parsed)] + #;[compare-parsed-to-parsed-marshalled + #f + (equal?/why-not parse-orig parse-marshalled)] + #;[marshal-marshalled + #t + (zo-marshal parse-marshalled)] + #;[compare-marshalled-to-marshalled-marshalled + #f + (bytes-not-equal?-error marshal-parsed marshal-marshalled)] + #;[replace-with-marshalled + #t + (replace-file file marshal-marshalled)] + #;[decompile-parsed + #t + (decompile parse-orig)] + [c-parse-marshalled + #t + (read-compiled-bytes marshal-parsed)] + #;[compare-orig-to-marshalled + #f + (bytes-not-equal?-error read-orig marshal-parsed)]) + +(define RESULTS empty) +(define (record! v) + (set! RESULTS (list* v RESULTS))) +(define (run-test file) + (run-with-limit + file + (* 1024 1024 512) + (lambda () + (run! file))) + (write (reverse RESULTS))) + +(command-line #:program "zo-test-worker" + #:args (file) + (run-test file)) + +(module test racket/base) diff --git a/compiler-test/tests/compiler/zo-test.rkt b/compiler-test/tests/compiler/zo-test.rkt new file mode 100755 index 0000000000..6bd475bbaa --- /dev/null +++ b/compiler-test/tests/compiler/zo-test.rkt @@ -0,0 +1,235 @@ +#!/bin/sh +#| +exec racket -t "$0" -- -s -t 60 -v -R $* +|# + +#lang racket +(require setup/dirs + racket/runtime-path + racket/future + compiler/find-exe + "zo-test-util.rkt") + +(define ((make-recorder! ht) file phase) + (hash-update! ht phase (curry list* file) empty)) + +(define stop-on-first-error (make-parameter #f)) +(define verbose-mode (make-parameter #f)) +(define care-about-nonserious? (make-parameter #t)) +(define invariant-output (make-parameter #f)) +(define time-limit (make-parameter +inf.0)) +(define randomize (make-parameter #f)) +(define num-processes (make-parameter (processor-count))) + +(define errors (make-hash)) +(define (record-common-error! exn-msg) + (hash-update! errors (common-message exn-msg) add1 0)) + +(define (common-message exn-msg) + (define given-messages (regexp-match #rx".*given" exn-msg)) + (if (and given-messages (not (empty? given-messages))) + (first given-messages) + exn-msg)) + +(define success-ht (make-hasheq)) +(define success! (make-recorder! success-ht)) +(define failure-ht (make-hasheq)) +(define failure! (make-recorder! failure-ht)) + +(define debugging? (make-parameter #f)) + +(define (randomize-list l) + (define ll (length l)) + (define seen? (make-hasheq)) + (let loop ([t 0]) + (if (= t ll) + empty + (let ([i (random ll)]) + (if (hash-has-key? seen? i) + (loop t) + (begin (hash-set! seen? i #t) + (list* (list-ref l i) + (loop (add1 t))))))))) + +(define (maybe-randomize-list l) + (if (randomize) (randomize-list l) l)) + +(define (for-zos ! p) + (define p-str (if (path? p) (path->string p) p)) + (cond + [(directory-exists? p) + (for ([sp (in-list (maybe-randomize-list (directory-list p)))]) + (for-zos ! (build-path p sp)))] + [(regexp-match #rx"\\.zo$" p-str) + (! p-str)])) + +(define-runtime-path zo-test-worker-path "zo-test-worker.rkt") +(define racket-path (path->string (find-exe))) + +(define p + (command-line #:program "zo-test" + #:once-each + [("-D") + "Enable debugging output" + (debugging? #t)] + [("-s" "--stop-on-first-error") + "Stop testing when first error is encountered" + (stop-on-first-error #t)] + [("-S") + "Don't take some errors seriously" + (care-about-nonserious? #f)] + [("-v" "--verbose") + "Display verbose error messages" + (verbose-mode #t)] + [("-I") + "Invariant output" + (invariant-output #t)] + [("-R") + "Randomize" + (randomize #t)] + [("-t") + number + "Limit the run to a given amount of time" + (time-limit (string->number number))] + [("-j") + n + "Run in parallel" + (num-processes (string->number n))] + #:args p + (if (empty? p) + (list (find-collects-dir)) + p))) + +(define to-worker-ch (make-channel)) +(define stop-ch (make-channel)) +(define from-worker-ch (make-channel)) + +(define worker-threads + (for/list ([i (in-range (num-processes))]) + (thread + (λ () + (let loop () + (sync + (handle-evt to-worker-ch + (λ (p) + (when (debugging?) + (printf "~a\n" p)) + (define-values + (sp stdout stdin stderr) + (subprocess #f #f #f racket-path (path->string zo-test-worker-path) p)) + (define r + (dynamic-wind + void + (λ () + (read stdout)) + (λ () + (close-input-port stdout) + (close-input-port stderr) + (close-output-port stdin) + (subprocess-kill sp #t)))) + (channel-put from-worker-ch (cons p r)) + (loop))) + (handle-evt stop-ch + (λ (die) + (void))))))))) + +(define (process-result p r) + (match r + [(success phase) + (success! p phase)] + [(failure phase serious? exn-msg) + (record-common-error! exn-msg) + (failure! p phase) + + (unless (and (not (care-about-nonserious?)) (not serious?)) + (when (or (verbose-mode) (stop-on-first-error)) + (eprintf "~a -- ~a: ~a\n" p phase exn-msg)) + (when (stop-on-first-error) + (stop!)))])) + +(define timing-thread + (thread + (λ () + (sync + (alarm-evt (+ (current-inexact-milliseconds) + (* 1000 (time-limit))))) + (stop!)))) + +(define server-thread + (thread + (λ () + (let loop ([ts worker-threads]) + (if (empty? ts) + (stop!) + (apply + sync + (handle-evt from-worker-ch + (match-lambda + [(cons p rs) + (for-each (curry process-result p) rs) + (loop ts)])) + (for/list ([t (in-list ts)]) + (handle-evt t (λ _ (loop (remq t ts))))))))))) + +(define (spawn-worker p) + (channel-put to-worker-ch p)) + +(define (zo-test paths) + (for-each (curry for-zos spawn-worker) paths) + + (for ([i (in-range (processor-count))]) + (channel-put stop-ch #t))) + +(define root-thread + (thread + (λ () + (zo-test p)))) + +(define final-sema (make-semaphore 0)) +(define (stop!) + (semaphore-post final-sema)) + +(define (hash-keys ht) + (hash-map ht (λ (k v) k))) + +(define final-thread + (thread + (λ () + (semaphore-wait final-sema) + (for-each kill-thread + (list* root-thread server-thread worker-threads)) + (unless (invariant-output) + (newline) + (for ([kind-name + (remove-duplicates + (append + (hash-keys failure-ht) + (hash-keys success-ht)))]) + (define fails (length (hash-ref failure-ht kind-name empty))) + (define succs (length (hash-ref success-ht kind-name empty))) + (define all (+ fails succs)) + (unless (zero? all) + (printf "~S\n" + `(,kind-name + (#f ,fails) + (#t ,succs) + ,all)))) + (newline) + (printf "~a tests passed\n" (length (hash-ref success-ht 'everything empty))) + + (let ([common-errors + (sort (filter (λ (p) ((car p) . > . 10)) + (hash-map errors (λ (k v) (cons v k)))) + > #:key car)]) + (unless (empty? common-errors) + (printf "Common Errors:\n") + (for ([p (in-list common-errors)]) + (printf "~a:\n~a\n\n" (car p) (cdr p))))))))) + +(thread-wait final-thread) + +;; Test mode: +(module test racket/base + (require syntax/location) + (parameterize ([current-command-line-arguments (vector "-I" "-S" "-t" "60" "-v" "-R")]) + (dynamic-require (quote-module-path "..") #f))) diff --git a/compiler-test/tests/compiler/zo.rkt b/compiler-test/tests/compiler/zo.rkt new file mode 100644 index 0000000000..c53f806773 --- /dev/null +++ b/compiler-test/tests/compiler/zo.rkt @@ -0,0 +1,84 @@ +#lang racket/base +(require racket/pretty + compiler/zo-parse + compiler/zo-marshal + compiler/decompile + racket/file) + +(define ex-mod1 + '(module m racket + (begin-for-syntax + (define fs 10) + (list fs)) + (define-syntax (m stx) + #'10) + (m) + (begin-for-syntax + (list fs)))) + +(define ex-mod2 + '(module m racket + (define t 8) + (define s 10) + (provide t (protect-out s)))) + +(define ex-mod3 + '(module m racket/base + (module* a racket/base + (provide a) + (define a 1) + (module* a+ racket/base + (define a+ 1.1))) + (module* b racket/base + (require (submod "." ".." a)) + (provide b) + (define b (+ a 1))))) + +(define ex-mod4 + '(module m racket/base + (module a racket/base + (provide a) + (define a 1) + (module a+ racket/base + (define a+ 1.1))) + (module b racket/base + (require (submod "." ".." a)) + (provide b) + (define b (+ a 1))))) + +(define ex-mod5 + '(module m racket/base + (module a racket/base + (provide a) + (define a 1) + (module* a+ racket/base + (define a+ 1.1))) + (module* b racket/base + (require (submod "." ".." a)) + (provide b) + (define b (+ a 1))))) + +(define (check ex-mod) + (let ([c (parameterize ([current-namespace (make-base-namespace)]) + (compile ex-mod))]) + (let ([o (open-output-bytes)]) + (write c o) + (let ([p (zo-parse (open-input-bytes (get-output-bytes o)))]) + (let ([b (zo-marshal p)]) + ;; Check that submodule table is ok: + (parameterize ([read-accept-compiled #t] + [current-output-port (open-output-bytes)]) + (define f (make-temporary-file)) + (call-with-output-file f #:exists 'truncate (lambda (f) (display b f))) + (dynamic-require f #f)) + (let ([p2 (zo-parse (open-input-bytes b))] + [to-string (lambda (p) + (let ([o (open-output-bytes)]) + (print p o) + (get-output-string o)))]) + (define s1 (to-string p)) + (define s2 (to-string p2)) + (unless (equal? s1 s2) + (error 'zo "failed on example: ~e\n~s\n~s" ex-mod s1 s2)))))))) + +(for-each check (list ex-mod1 ex-mod2 ex-mod3 ex-mod4 ex-mod5)) diff --git a/compiler/LICENSE.txt b/compiler/LICENSE.txt new file mode 100644 index 0000000000..5fdef4b767 --- /dev/null +++ b/compiler/LICENSE.txt @@ -0,0 +1,11 @@ +compiler +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. diff --git a/compiler/info.rkt b/compiler/info.rkt new file mode 100644 index 0000000000..374ab02d83 --- /dev/null +++ b/compiler/info.rkt @@ -0,0 +1,10 @@ +#lang info + +(define collection 'multi) + +(define deps '("compiler-lib")) +(define implies '("compiler-lib")) + +(define pkg-desc "Racket compilation tools, such as `raco exe'") + +(define pkg-authors '(mflatt)) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt new file mode 100644 index 0000000000..d2d55248f3 --- /dev/null +++ b/zo-lib/compiler/zo-marshal.rkt @@ -0,0 +1,1522 @@ +#lang racket/base +(require compiler/zo-structs + racket/port + racket/vector + racket/match + racket/contract + racket/local + racket/list + racket/dict + racket/function + racket/pretty + racket/path + racket/set + racket/extflonum) + +(provide/contract + [zo-marshal (compilation-top? . -> . bytes?)] + [zo-marshal-to (compilation-top? output-port? . -> . void?)]) + +(struct not-ready ()) + +(struct encoded-scope (relative-id [content #:mutable]) #:prefab) + +(define (zo-marshal top) + (define bs (open-output-bytes)) + (zo-marshal-to top bs) + (get-output-bytes bs)) + +(define (zo-marshal-to top outp) + (if (and (mod? (compilation-top-code top)) + (or (pair? (mod-pre-submodules (compilation-top-code top))) + (pair? (mod-post-submodules (compilation-top-code top))))) + ;; module directory and submodules: + (zo-marshal-modules-to top outp) + ;; single module or other: + (zo-marshal-top-to top outp))) + +(define (zo-marshal-modules-to top outp) + ;; Write the compiled form header + (write-bytes #"#~" outp) + ;; Write the version: + (define version-bs (string->bytes/latin-1 (version))) + (write-bytes (bytes (bytes-length version-bs)) outp) + (write-bytes version-bs outp) + + (write-byte (char->integer #\D) outp) + + (struct mod-bytes (code-bstr name-bstr offset)) + ;; bytestring encodings of the modules and module names + ;; --- in the order that they must be written: + (define pre-mod-bytess + (reverse + (let loop ([m (compilation-top-code top)] [pre-accum null]) + (define (encode-module-name name) + (if (symbol? name) + #"" + (apply bytes-append + (for/list ([sym (in-list (cdr name))]) + (define b (string->bytes/utf-8 (symbol->string sym))) + (define len (bytes-length b)) + (bytes-append (if (len . < . 255) + (bytes len) + (bytes-append + (bytes 255) + (integer->integer-bytes len 4 #f #f))) + b))))) + (define accum + (let iloop ([accum pre-accum] [subm (mod-pre-submodules m)]) + (if (null? subm) + accum + (iloop (loop (car subm) accum) (cdr subm))))) + (define o (open-output-bytes)) + (zo-marshal-top-to (struct-copy compilation-top top + [code (struct-copy mod m + [pre-submodules null] + [post-submodules null])]) + o) + (define new-accum + (cons (mod-bytes (get-output-bytes o) + (encode-module-name (mod-name m)) + 0) + accum)) + (let iloop ([accum new-accum] [subm (mod-post-submodules m)]) + (if (null? subm) + accum + (iloop (loop (car subm) accum) (cdr subm))))))) + (write-bytes (int->bytes (length pre-mod-bytess)) outp) + ;; Size of btree: + (define header-size + (+ 8 + (string-length (version)))) + (define btree-size + (+ header-size + (apply + (for/list ([mb (in-list pre-mod-bytess)]) + (+ (bytes-length (mod-bytes-name-bstr mb)) + 20))))) + ;; Add offsets to mod-bytess: + (define mod-bytess (let loop ([offset btree-size] [mod-bytess pre-mod-bytess]) + (if (null? mod-bytess) + null + (let ([mb (car mod-bytess)]) + (cons (mod-bytes (mod-bytes-code-bstr mb) + (mod-bytes-name-bstr mb) + offset) + (loop (+ offset + (bytes-length (mod-bytes-code-bstr mb))) + (cdr mod-bytess))))))) + ;; Sort by name for btree order: + (define sorted-mod-bytess + (list->vector (sort mod-bytess bytesbytes name-len) outp) + (write-bytes (mod-bytes-name-bstr mb) outp) + (write-bytes (int->bytes (mod-bytes-offset mb)) outp) + (write-bytes (int->bytes (bytes-length (mod-bytes-code-bstr mb))) outp) + (define left-pos (+ pos name-len 20)) + (write-bytes (int->bytes (if (= lo mid) + 0 + left-pos)) + outp) + (write-bytes (int->bytes (if (= (add1 mid) hi) + 0 + (vector-ref right-offsets mid))) + outp) + (define right-pos (if (= lo mid) + left-pos + (loop lo mid left-pos))) + (vector-set! right-offsets mid right-pos) + (if (= (add1 mid) hi) + right-pos + (loop (add1 mid) hi right-pos)))) + (write-btree void) ; to fill `right-offsets' + (write-btree write-bytes) ; to actually write the btree + ;; write modules: + (for ([mb (in-list mod-bytess)]) + (write-bytes (mod-bytes-code-bstr mb) outp))) + +(define (zo-marshal-top-to top outp) + + ; For detecting sharing in wraps: + (define stx-objs (make-hasheq)) + (define wraps (make-hasheq)) + (define hash-consed (make-hash)) + (define hash-consed-results (make-hasheq)) + + ; (obj -> (or pos #f)) output-port -> number + ; writes top to outp using shared-obj-pos to determine symref + ; returns the file position at the end of the compilation top + (define (out-compilation-top shared-obj-pos shared-obj-pos-any counting? outp) + (define ct + (match top + [(compilation-top max-let-depth binding-namess prefix form) + (list* max-let-depth + (binding-namess-hash->list binding-namess) + prefix + (protect-quote form))])) + (out-anything ct (make-out outp shared-obj-pos shared-obj-pos-any counting? + stx-objs wraps hash-consed hash-consed-results)) + (file-position outp)) + + ; -> vector + ; calculates what values show up in the compilation top more than once + ; closures are always included even if they only show up once + (define (create-symbol-table) + (define encountered (make-hasheq)) + (define shared (make-hasheq)) + (define (encountered? v) + ((hash-ref encountered v 0) . > . 0)) + (define (encounter! v) + (hash-update! encountered v add1 0) + #f) + (define (shared-obj-pos v #:error? [error? #f]) + (hash-ref shared v + (if error? + (λ () (error 'symref "~e not in symbol table" v)) + #f))) + (define (share! v) + (or (shared-obj-pos v) + (let ([pos (add1 (hash-count shared))]) + (hash-set! shared v pos) + pos))) + + (out-compilation-top + (λ (v #:error? [error? #f]) + (cond + [(hash? v) (error 'create-symbol-table "current type trace: ~a" (current-type-trace))] + [(closure? v) + (let ([pos (share! v)]) + (if (encountered? v) + pos + (encounter! v)))] + [error? ; If we would error if this were not present, then we must share it + (encounter! v) + (share! v)] + [(encountered? v) + (share! v)] + [else + (encounter! v)])) + (lambda (v) #f) + #t + (open-output-nowhere)) + + (define symbol-table (make-vector (hash-count shared) (not-ready))) + (hash-map shared (λ (k v) (vector-set! symbol-table (sub1 v) k))) + (values symbol-table shared-obj-pos)) + + (define-values (symbol-table shared-obj-pos) + (create-symbol-table)) + + ; vector output-port -> (listof number) number + ; writes symbol-table to outp + ; returns the file positions of each value in the symbol table and the end of the symbol table + (define (out-symbol-table symbol-table outp) + (define (shared-obj-pos/modulo-v v) + (define skip? #t) + (λ (v2 #:error? [error? #f]) + (if (and skip? (eq? v v2)) + (begin + (set! skip? #f) + #f) + (shared-obj-pos v2 + #:error? error?)))) + (values + (for/list ([v (in-vector symbol-table)] + [i (in-naturals)]) + (begin0 + (file-position outp) + (out-anything v (make-out outp (shared-obj-pos/modulo-v v) shared-obj-pos #f + stx-objs wraps hash-consed hash-consed-results)))) + (file-position outp))) + + ; Calculate file positions + (define counting-port (open-output-nowhere)) + (define-values (offsets post-shared) (out-symbol-table symbol-table counting-port)) + (define all-forms-length (out-compilation-top shared-obj-pos shared-obj-pos #f counting-port)) + + ; Write the compiled form header + (write-bytes #"#~" outp) + + ; Write the version (notice that it isn't the same as out-string) + (define version-bs (string->bytes/latin-1 (version))) + (write-bytes (bytes (bytes-length version-bs)) outp) + (write-bytes version-bs outp) + + (write-byte (char->integer #\T) outp) + + ; Write empty hash code + (write-bytes (make-bytes 20 0) outp) + + ; Write the symbol table information (size, offsets) + (define symtabsize (add1 (vector-length symbol-table))) + (write-bytes (int->bytes symtabsize) outp) + (define all-short? (post-shared . < . #xFFFF)) + (write-bytes (bytes (if all-short? 1 0)) outp) + (for ([o (in-list offsets)]) + (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) + ; Post-shared is where the ctop actually starts + (write-bytes (int->bytes post-shared) outp) + ; This is where the file should end + (write-bytes (int->bytes all-forms-length) outp) + ; Actually write the zo + (out-symbol-table symbol-table outp) + (out-compilation-top shared-obj-pos shared-obj-pos #f outp) + (void)) + +;; ---------------------------------------- + +(define toplevel-type-num 0) +(define sequence-type-num 6) +(define unclosed-procedure-type-num 8) +(define let-value-type-num 9) +(define let-void-type-num 10) +(define letrec-type-num 11) +(define wcm-type-num 13) +(define quote-syntax-type-num 14) +(define define-values-type-num 15) +(define define-syntaxes-type-num 16) +(define begin-for-syntax-type-num 17) +(define set-bang-type-num 18) +(define boxenv-type-num 19) +(define begin0-sequence-type-num 20) +(define splice-sequence-type-num 21) +(define require-form-type-num 22) +(define varref-form-type-num 23) +(define apply-values-type-num 24) +(define with-immed-mark-type-num 25) +(define case-lambda-sequence-type-num 26) +(define module-type-num 27) +(define inline-variants-type-num 28) +(define variable-type-num 37) +(define prefix-type-num 122) + +(define-syntax define-enum + (syntax-rules () + [(_ n) (begin)] + [(_ n id . rest) + (begin + (define id n) + (define-enum (add1 n) . rest))])) + +(define-enum + 0 + CPT_ESCAPE + CPT_SYMBOL + CPT_SYMREF + CPT_WEIRD_SYMBOL + CPT_KEYWORD + CPT_BYTE_STRING + CPT_CHAR_STRING + CPT_CHAR + CPT_INT + CPT_NULL + CPT_TRUE + CPT_FALSE + CPT_VOID + CPT_BOX + CPT_PAIR + CPT_LIST + CPT_VECTOR + CPT_HASH_TABLE + CPT_STX + CPT_LET_ONE_TYPED + CPT_MARSHALLED + CPT_QUOTE + CPT_REFERENCE + CPT_LOCAL + CPT_LOCAL_UNBOX + CPT_SVECTOR + CPT_APPLICATION + CPT_LET_ONE + CPT_BRANCH + CPT_MODULE_INDEX + CPT_MODULE_VAR + CPT_PATH + CPT_CLOSURE + CPT_DELAY_REF ; XXX should be used to delay loading of syntax objects and lambda bodies + CPT_PREFAB + CPT_LET_ONE_UNUSED + CPT_SCOPE + CPT_ROOT_SCOPE + CPT_SHARED) + +(define CPT_SMALL_NUMBER_START 39) +(define CPT_SMALL_NUMBER_END 62) + +(define CPT_SMALL_SYMBOL_START 62) +(define CPT_SMALL_SYMBOL_END 80) + +(define CPT_SMALL_MARSHALLED_START 80) +(define CPT_SMALL_MARSHALLED_END 92) + +(define CPT_SMALL_LIST_MAX 50) +(define CPT_SMALL_PROPER_LIST_START 92) +(define CPT_SMALL_PROPER_LIST_END (+ CPT_SMALL_PROPER_LIST_START CPT_SMALL_LIST_MAX)) + +(define CPT_SMALL_LIST_START CPT_SMALL_PROPER_LIST_END) +(define CPT_SMALL_LIST_END 192) + +(define CPT_SMALL_LOCAL_START 192) +(define CPT_SMALL_LOCAL_END 207) +(define CPT_SMALL_LOCAL_UNBOX_START 207) +(define CPT_SMALL_LOCAL_UNBOX_END 222) + +(define CPT_SMALL_SVECTOR_START 222) +(define CPT_SMALL_SVECTOR_END 247) + +(define CPT_SMALL_APPLICATION_START 247) +(define CPT_SMALL_APPLICATION_END 255) + +(define CLOS_HAS_REST 1) +(define CLOS_HAS_REF_ARGS 2) +(define CLOS_PRESERVES_MARKS 4) +(define CLOS_NEED_REST_CLEAR 8) +(define CLOS_IS_METHOD 16) +(define CLOS_SINGLE_RESULT 32) + +(define BITS_PER_MZSHORT 32) +(define BITS_PER_ARG 4) + +(define (int->bytes x) + (integer->integer-bytes x + 4 + #f + #f)) + +(define-struct protected-symref (val)) + +(define (encode-stx-obj w out) + (match w + [(struct stx-obj (datum wraps srcloc props tamper-status)) + (let* ([enc-datum + (match datum + [(cons a b) + (let ([p (cons (encode-stx-obj a out) + (let bloop ([b b]) + (match b + ['() null] + [(cons b1 b2) + (cons (encode-stx-obj b1 out) + (bloop b2))] + [else + (encode-stx-obj b out)])))] + [len (let loop ([datum datum][len 0]) + (cond + [(null? datum) #f] + [(pair? datum) (loop (cdr datum) (add1 len))] + [else len]))]) + ;; for improper lists, we need to include the length so the + ;; parser knows where the end of the improper list is + (if len + (cons len p) + p))] + [(box x) + (box (encode-stx-obj x out))] + [(? vector? v) + (vector-map (lambda (e) (encode-stx-obj e out)) v)] + [(? prefab-struct-key) + (define l (vector->list (struct->vector datum))) + (apply + make-prefab-struct + (car l) + (map (lambda (e) (encode-stx-obj e out)) (cdr l)))] + [_ datum])] + [e-wraps (share-everywhere (encode-wrap wraps (out-wraps out)) out)] + [esrcloc (let () + (define (avail? n) (n . >= . 0)) + (define (xvector a b c d e) + ;; Add paren-shape info, if any: + (case (hash-ref props 'paren-shape #f) + [(#\[) (yvector a b c d e #\[)] + [(#\{) (yvector a b c d e #\{)] + [else (if (or a (avail? b) (avail? c) (avail? d)) + (yvector a b c d e #f) + #f)])) + (define (yvector a b c d e f) + ;; Add properties, if any: + (if (positive? (- (hash-count props) (if f 1 0))) + (vector a b c d e f + (sort (for/list ([(k v) (in-hash props)] + #:unless (and f + (eq? k 'paren-shape))) + (cons k v)) + symbol . -32) + (out-byte (bitwise-ior #xC0 (- n)) out) + (begin + (out-byte #xE0 out) + (out-bytes (int->bytes (- n)) out)))] + [(n . < . 128) + (out-byte n out)] + [(n . < . #x4000) + (out-byte (bitwise-ior #x80 (bitwise-and n #x3F)) out) + (out-byte (bitwise-and #xFF (arithmetic-shift n -6)) out)] + [else + (out-byte #xF0 out) + (out-bytes (int->bytes n) out)])) + +(define (out-marshaled type-num val out) + (if (type-num . < . (- CPT_SMALL_MARSHALLED_END CPT_SMALL_MARSHALLED_START)) + (out-byte (+ CPT_SMALL_MARSHALLED_START type-num) out) + (begin + (out-byte CPT_MARSHALLED out) + (out-number type-num out))) + (out-anything val out)) + +(define (or-pred? v . ps) + (ormap (lambda (?) (? v)) ps)) + +(define quoting? (make-parameter #f)) + +(define (shareable? v) + (define never-share-this? + (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash? + ;; For root scope: + scope?)) + (define always-share-this? + (or-pred? v closure?)) + (or always-share-this? + (if (quoting?) + #f + (not never-share-this?)))) + +(define (maybe-same-as-fixnum? v) + (and (exact-integer? v) + (and (v . >= . -1073741824) (v . <= . 1073741823)))) + +(define (current-type-trace) + (reverse (continuation-mark-set->list (current-continuation-marks) 'zo))) + +(define (typeof v) + (cond + [(pair? v) 'cons] + [(hash? v) 'hash] + [(prefab-struct-key v) => (λ (key) key)] + [(vector? v) 'vector] + [else v])) + +(define-syntax with-type-trace + (syntax-rules () + [(_ v body ...) + #;(begin body ...) + (with-continuation-mark 'zo (typeof v) + (begin0 (begin body ...) (void)))])) + +(define (type->index type) + (case type + [(flonum) 1] + [(fixnum) 2] + [(extflonum) 3] + [else (error 'type->index "unknown type: ~e" type)])) + +(define (out-anything v out) + (with-type-trace v + (out-shared + v out + (λ () + (match v + [(? char?) + (out-byte CPT_CHAR out) + (out-number (char->integer v) out)] + [(? maybe-same-as-fixnum?) + (if (and (v . >= . 0) + (v . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START))) + (out-byte (+ CPT_SMALL_NUMBER_START v) out) + (begin + (out-byte CPT_INT out) + (out-number v out)))] + [(list) + (out-byte CPT_NULL out)] + [#t + (out-byte CPT_TRUE out)] + [#f + (out-byte CPT_FALSE out)] + [(? void?) + (out-byte CPT_VOID out)] + [(? (lambda (s) (and (scope? s) (eq? (scope-name s) 'root)))) + (out-byte CPT_ROOT_SCOPE out)] + [(struct module-variable (modidx sym pos phase constantness)) + (define (to-sym n) (string->symbol (format "struct~a" n))) + (out-byte CPT_MODULE_VAR out) + (out-anything modidx out) + (out-anything sym out) + (out-anything (cond + [(function-shape? constantness) + (let ([a (function-shape-arity constantness)]) + (cond + [(arity-at-least? a) + (bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1) + (if (function-shape-preserves-marks? constantness) 1 0))] + [(list? a) + (string->symbol (apply + string-append + (add-between + (for/list ([a (in-list a)]) + (define n (if (arity-at-least? a) + (- (add1 (arity-at-least-value a))) + a)) + (number->string n)) + ":")))] + [else + (bitwise-ior (arithmetic-shift a 1) + (if (function-shape-preserves-marks? constantness) 1 0))]))] + [(struct-type-shape? constantness) + (to-sym (arithmetic-shift (struct-type-shape-field-count constantness) + 4))] + [(constructor-shape? constantness) + (to-sym (bitwise-ior 1 (arithmetic-shift (constructor-shape-arity constantness) + 4)))] + [(predicate-shape? constantness) (to-sym 2)] + [(accessor-shape? constantness) + (to-sym (bitwise-ior 3 (arithmetic-shift (accessor-shape-field-count constantness) + 4)))] + [(mutator-shape? constantness) + (to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness) + 4)))] + [(struct-other-shape? constantness) + (to-sym 5)] + [else #f]) + out) + (case constantness + [(#f) (void)] + [(fixed) (out-number -5 out)] + [else (out-number -4 out)]) + (unless (zero? phase) + (out-number -2 out) + (out-number phase out)) + (out-number pos out)] + [(struct closure (lam gen-id)) + (out-byte CPT_CLOSURE out) + (let ([pos ((out-shared-index out) v #:error? #t)]) + (out-number pos out) + (out-anything lam out))] + [(struct prefix (num-lifts toplevels stxs src-insp-desc)) + (out-marshaled + prefix-type-num + (list* src-insp-desc + num-lifts + (list->vector toplevels) + (list->vector stxs)) + out)] + [(struct global-bucket (name)) + (out-marshaled variable-type-num name out)] + [(? mod?) + (out-module v out)] + [(struct def-values (ids rhs)) + (out-marshaled define-values-type-num + (list->vector (cons (protect-quote rhs) ids)) + out)] + [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) + (out-marshaled define-syntaxes-type-num + (list->vector (list* (protect-quote rhs) + prefix + max-let-depth + dummy + ids)) + out)] + [(struct seq-for-syntax (rhs prefix max-let-depth dummy)) + (out-marshaled begin-for-syntax-type-num + (vector (map protect-quote rhs) + prefix + max-let-depth + dummy) + out)] + [(struct beg0 (forms)) + (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] + [(struct seq (forms)) + (out-marshaled sequence-type-num (map protect-quote forms) out)] + [(struct splice (forms)) + (out-marshaled splice-sequence-type-num forms out)] + [(struct req (reqs dummy)) + (out-marshaled require-form-type-num (cons dummy reqs) out)] + [(struct toplevel (depth pos const? ready?)) + (out-marshaled toplevel-type-num + (cons + depth + (if (or const? ready?) + (cons pos + (bitwise-ior + (if const? #x2 0) + (if ready? #x1 0))) + pos)) + out)] + [(struct topsyntax (depth pos midpt)) + (out-marshaled quote-syntax-type-num + (cons depth + (cons pos midpt)) + out)] + [(struct primval (id)) + (out-byte CPT_REFERENCE out) + (out-number id out)] + [(struct assign (id rhs undef-ok?)) + (out-marshaled set-bang-type-num + (cons undef-ok? (cons id (protect-quote rhs))) + out)] + [(struct localref (unbox? offset clear? other-clears? type)) + (if (and (not clear?) (not other-clears?) (not flonum?) + (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) + (out-byte (+ (if unbox? + CPT_SMALL_LOCAL_UNBOX_START + CPT_SMALL_LOCAL_START) + offset) + out) + (begin + (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) + (if (not (or clear? other-clears? type)) + (out-number offset out) + (begin + (out-number (- (add1 offset)) out) + (out-number (cond + [clear? 1] + [other-clears? 2] + [else (+ 2 (type->index type))]) + out)))))] + [(? lam?) + (out-lam v out)] + [(struct case-lam (name lams)) + (out-marshaled case-lambda-sequence-type-num + (cons (or name null) + lams) + out)] + [(struct let-one (rhs body type unused?)) + (out-byte (cond + [type CPT_LET_ONE_TYPED] + [unused? CPT_LET_ONE_UNUSED] + [else CPT_LET_ONE]) + out) + (out-anything (protect-quote rhs) out) + (out-anything (protect-quote body) out) + (when type + (out-number (type->index type) out))] + [(struct let-void (count boxes? body)) + (out-marshaled let-void-type-num + (list* + count + boxes? + (protect-quote body)) + out)] + [(struct let-rec (procs body)) + (out-marshaled letrec-type-num + (list* + (length procs) + (protect-quote body) + procs) + out)] + [(struct install-value (count pos boxes? rhs body)) + (out-marshaled let-value-type-num + (list* + count + pos + boxes? + (protect-quote rhs) + (protect-quote body)) + out)] + [(struct boxenv (pos body)) + (out-marshaled boxenv-type-num + (cons + pos + (protect-quote body)) + out)] + [(struct branch (test then else)) + (out-byte CPT_BRANCH out) + (out-anything (protect-quote test) out) + (out-anything (protect-quote then) out) + (out-anything (protect-quote else) out)] + [(struct application (rator rands)) + (let ([len (length rands)]) + (if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START)) + (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out) + (begin + (out-byte CPT_APPLICATION out) + (out-number len out))) + (for-each (lambda (e) + (out-anything (protect-quote e) out)) + (cons rator rands)))] + [(struct apply-values (proc args-expr)) + (out-marshaled apply-values-type-num + (cons (protect-quote proc) + (protect-quote args-expr)) + out)] + [(struct with-immed-mark (key val body)) + (out-marshaled with-immed-mark-type-num + (vector + (protect-quote key) + (protect-quote val) + (protect-quote body)) + out)] + [(struct with-cont-mark (key val body)) + (out-marshaled wcm-type-num + (list* + (protect-quote key) + (protect-quote val) + (protect-quote body)) + out)] + [(struct varref (expr dummy)) + (out-marshaled varref-form-type-num + (cons expr dummy) + out)] + [(protected-symref v) + (out-anything ((out-shared-index out) v #:error? #t) out)] + [(and (? symbol?) (not (? symbol-interned?))) + (out-as-bytes v + #:before-length (if (symbol-unreadable? v) 0 1) + (compose string->bytes/utf-8 symbol->string) + CPT_WEIRD_SYMBOL + #f + out)] + [(? symbol?) + (define bs (string->bytes/utf-8 (symbol->string v))) + (define len (bytes-length bs)) + (if (len . < . (- CPT_SMALL_SYMBOL_END CPT_SMALL_SYMBOL_START)) + (out-byte (+ CPT_SMALL_SYMBOL_START len) out) + (begin (out-byte CPT_SYMBOL out) + (out-number len out))) + (out-bytes bs out)] + [(? keyword?) + (out-as-bytes v + (compose string->bytes/utf-8 keyword->string) + CPT_KEYWORD + #f + out)] + [(? string?) + (out-as-bytes v + string->bytes/utf-8 + CPT_CHAR_STRING + (string-length v) + out)] + [(? bytes?) + (out-as-bytes v + values + CPT_BYTE_STRING + #f + out)] + [(? box?) + (out-byte CPT_BOX out) + (out-anything (unbox v) out)] + [(? pair?) + (define (list-length-before-cycle/improper-end l) + (let loop ([len 0] [l l]) + (cond + [(null? l) + (values len #t)] + [(pair? l) + (if ((out-shared-index out) l) + (values len #f) + (loop (add1 len) (cdr l)))] + [else + (values len #f)]))) + + (define-values (len-1 proper?) + (if (out-counting? out) + (values 0 #f) + (list-length-before-cycle/improper-end (cdr v)))) + (define len (add1 len-1)) + + (define (print-contents-as-proper) + (for ([e (in-list v)]) + (out-anything e out))) + (define (print-contents-as-improper) + (let loop ([l v] [i len]) + (cond + [(zero? i) + (out-anything l out)] + [else + (out-anything (car l) out) + (loop (cdr l) (sub1 i))]))) + (if proper? + (if (len . < . (- CPT_SMALL_PROPER_LIST_END CPT_SMALL_PROPER_LIST_START)) + (begin (out-byte (+ CPT_SMALL_PROPER_LIST_START len) out) + (print-contents-as-proper)) + (begin (out-byte CPT_LIST out) + (out-number len out) + (print-contents-as-proper) + (out-anything null out))) + (if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START)) + ; XXX If len = 1 (or maybe = 2?) then this could by CPT_PAIR + (begin (out-byte (+ CPT_SMALL_LIST_START len) out) + (print-contents-as-improper)) + (begin (out-byte CPT_LIST out) + (out-number len out) + (print-contents-as-improper))))] + [(? vector?) + (out-byte CPT_VECTOR out) + (out-number (vector-length v) out) + (for ([v (in-vector v)]) + (out-anything v out))] + [(? hash?) + (out-byte CPT_HASH_TABLE out) + (out-number (cond + [(hash-eqv? v) 2] + [(hash-eq? v) 0] + [(hash-equal? v) 1]) + out) + (out-number (hash-count v) out) + (for ([(k v) (in-hash v)]) + (out-anything k out) + (out-anything v out))] + [(svector vec) + (let* ([len (vector-length vec)]) + (if (len . < . (- CPT_SMALL_SVECTOR_END CPT_SMALL_SVECTOR_START)) + (out-byte (+ CPT_SMALL_SVECTOR_START len) out) + (begin (out-byte CPT_SVECTOR out) + (out-number len out))) + (for ([n (in-range (sub1 len) -1 -1)]) + (out-number (vector-ref vec n) out)))] + [(? module-path-index?) + ;; XXX should add interning of module path indices + (out-byte CPT_MODULE_INDEX out) + (let-values ([(name base) (module-path-index-split v)]) + (out-anything name out) + (out-anything base out) + (unless (or name base) + (out-anything (module-path-index-submodule v) out)))] + [(stx content) + (out-byte CPT_STX out) + (out-anything content out)] + [(encoded-scope relative-id content) + (out-byte CPT_SCOPE out) + ;; The `out-shared` wrapper already called `((out-shared-index out) v)` + ;; once, so `pos` will defintely be a number: + (let ([pos ((out-shared-index out) v)]) + (out-number pos out)) + (out-number relative-id out) + (out-anything (share-everywhere content out) out)] + [(? stx-obj?) + (out-anything (lookup-encoded-stx-obj v out) out)] + [(? prefab-struct-key) + (define pre-v (struct->vector v)) + (vector-set! pre-v 0 (prefab-struct-key v)) + (out-byte CPT_PREFAB out) + (out-anything pre-v out)] + [(quoted qv) + (out-byte CPT_QUOTE out) + (parameterize ([quoting? #t]) + (out-anything qv out))] + [(? path?) + (out-byte CPT_PATH out) + (define (within? p) + (and (relative-path? p) + (let loop ([p p]) + (define-values (base name dir?) (split-path p)) + (and (not (eq? name 'up)) + (not (eq? name 'same)) + (or (not (path? base)) + (loop base)))))) + (define maybe-rel + (and (current-write-relative-directory) + (let ([dir (current-write-relative-directory)]) + (and (or (not dir) + (within? (find-relative-path v + (if (pair? dir) + (cdr dir) + dir)))) + (find-relative-path v + (if (pair? dir) + (car dir) + dir)))))) + (cond + [(not maybe-rel) + (define bstr (path->bytes v)) + (out-number (bytes-length bstr) out) + (out-bytes bstr out)] + [else + (out-number 0 out) + (out-anything (for/list ([e (in-list (explode-path maybe-rel))]) + (if (path? e) + (path-element->bytes e) + e)) + out)])] + [(or (? regexp?) + (? byte-regexp?) + (? number?) + (? extflonum?)) + (out-byte CPT_QUOTE out) + (define s (open-output-bytes)) + (parameterize + ([pretty-print-size-hook + (lambda (v mode port) + (and (path? v) + (let ([v (make-relative v)]) + (+ 2 (let ([p (open-output-bytes)]) + (write (path->bytes v) p) + (bytes-length (get-output-bytes p)))))))] + [pretty-print-print-hook + (lambda (v mode port) + (display "#^" port) + (write (path->bytes (make-relative v)) port))]) + (pretty-write v s)) + (out-byte CPT_ESCAPE out) + (define bstr (get-output-bytes s)) + (out-number (bytes-length bstr) out) + (out-bytes bstr out)] + [else (error 'out-anything "~s" (current-type-trace))]))))) + +(define (out-module mod-form out) + (out-marshaled module-type-num + (convert-module mod-form) + out)) + +(define (convert-module mod-form) + (match mod-form + [(struct mod (name srcname self-modidx + prefix provides requires body syntax-bodies unexported + max-let-depth dummy lang-info + internal-context binding-names + flags pre-submodules post-submodules)) + (let* ([lookup-req (lambda (phase) + (let ([a (assq phase requires)]) + (if a + (cdr a) + null)))] + [other-requires (filter (lambda (l) + (not (memq (car l) '(#f -1 0 1)))) + requires)] + [extract-protects + (lambda (phase) + (let ([a (assq phase provides)]) + (and a + (let ([p (map provided-protected? (append (cadr a) + (caddr a)))]) + (if (ormap values p) + (list->vector p) + #f)))))] + [extract-unexported + (lambda (phase) + (let ([a (assq phase unexported)]) + (and a + (cdr a))))] + [list->vector/#f (lambda (default l) + (if (andmap (lambda (x) (equal? x default)) l) + #f + (list->vector l)))] + [l + (let loop ([l other-requires]) + (match l + [(list) + empty] + [(list-rest (cons phase reqs) rst) + (list* phase reqs (loop rst))]))] + [l (cons (length other-requires) l)] + [l (cons (lookup-req #f) l)] ; dt-requires + [l (cons (lookup-req -1) l)] ; tt-requires + [l (cons (lookup-req 1) l)] ; et-requires + [l (cons (lookup-req 0) l)] ; requires + [l (cons (list->vector body) l)] + [l (append (reverse + (for/list ([b (in-list syntax-bodies)]) + (for/vector ([i (in-list (cdr b))]) + (define (maybe-one l) ;; a single symbol is ok + (if (and (pair? l) (null? (cdr l))) + (car l) + l)) + (match i + [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) + (vector (maybe-one ids) rhs max-let-depth prefix #f)] + [(struct seq-for-syntax ((list rhs) prefix max-let-depth dummy)) + (vector #f rhs max-let-depth prefix #t)])))) + l)] + [l (append (apply + append + (map (lambda (l) + (let* ([phase (car l)] + [all (append (cadr l) (caddr l))] + [protects (extract-protects phase)] + [unexported (extract-unexported phase)]) + (append + (list phase) + (if (and (not protects) + (not unexported)) + (list (void)) + (let ([unexported (or unexported + '(() ()))]) + (list (list->vector (cadr unexported)) + (length (cadr unexported)) + (list->vector (car unexported)) + (length (car unexported)) + protects))) + (list (list->vector/#f 0 (map provided-src-phase all)) + (list->vector/#f #f (map (lambda (p) + (if (eq? (provided-nom-src p) + (provided-src p)) + #f ; #f means "same as src" + (provided-nom-src p))) + all)) + (list->vector (map provided-src-name all)) + (list->vector (map provided-src all)) + (list->vector (map provided-name all)) + (length (cadr l)) + (length all))))) + provides)) + l)] + [l (cons (length provides) l)] ; number of provide sets + [l (cons (add1 (length syntax-bodies)) l)] + [l (cons prefix l)] + [l (cons dummy l)] + [l (cons max-let-depth l)] + [l (cons internal-context l)] ; module->namespace syntax + [l (list* #f #f l)] ; obsolete `functional?' info + [l (cons (protect-quote lang-info) l)] ; lang-info + [l (cons (map convert-module post-submodules) l)] + [l (cons (map convert-module pre-submodules) l)] + [l (cons (if (memq 'cross-phase flags) #t #f) l)] + [l (append (pack-binding-names binding-names) l)] + [l (cons self-modidx l)] + [l (cons srcname l)] + [l (cons (if (pair? name) (car name) name) l)] + [l (cons (if (pair? name) (cdr name) null) l)]) + l)])) + +(define (lookup-encoded-stx-obj w out) + (hash-ref! (out-stx-objs out) w + (λ () + (encode-stx-obj w out)))) + +(define (pack-binding-names binding-names) + (define (ht-to-vector ht) + (and ht (list->vector (apply append (hash-map ht list))))) + (list (ht-to-vector (hash-ref binding-names 0 #f)) + (ht-to-vector (hash-ref binding-names 1 #f)) + (list->vector + (apply append + (for/list ([(phase ht) (in-hash binding-names)] + #:unless (or (= phase 0) (= phase 1))) + (list phase (ht-to-vector ht))))))) + +(define (out-lam expr out) + (match expr + [(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body)) + (let* ([l (protect-quote body)] + [any-refs? (or (not (andmap (lambda (t) (eq? t 'val)) param-types)) + (not (andmap (lambda (t) (eq? t 'val/ref)) closure-types)))] + [num-all-params (if (and rest? (not (memq 'only-rest-arg-not-used flags))) + (add1 num-params) + num-params)] + [l (cons (make-svector (if any-refs? + (list->vector + (append + (vector->list closure-map) + (let* ([v (make-vector (ceiling + (/ (* BITS_PER_ARG (+ num-params (vector-length closure-map))) + BITS_PER_MZSHORT)))] + [set-bit! (lambda (i bit) + (let ([pos (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)]) + (vector-set! v pos + (bitwise-ior (vector-ref v pos) + (arithmetic-shift + bit + (modulo (* BITS_PER_ARG i) BITS_PER_MZSHORT))))))]) + (for ([t (in-list param-types)] + [i (in-naturals)]) + (case t + [(val) (void)] + [(ref) (set-bit! i 1)] + [else (set-bit! i (+ 1 (type->index t)))])) + (for ([t (in-list closure-types)] + [i (in-naturals num-all-params)]) + (case t + [(val/ref) (void)] + [else (set-bit! i (+ 1 (type->index t)))])) + (vector->list v)))) + closure-map)) + l)] + [l (if any-refs? + (cons (vector-length closure-map) l) + l)] + [tl-map (and toplevel-map + (for/fold ([v 0]) ([i (in-set toplevel-map)]) + (bitwise-ior v (arithmetic-shift 1 i))))]) + (out-marshaled unclosed-procedure-type-num + (list* + (+ (if rest? CLOS_HAS_REST 0) + (if any-refs? CLOS_HAS_REF_ARGS 0) + (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) + (if (memq 'sfs-clear-rest-args flags) CLOS_NEED_REST_CLEAR 0) + (if (memq 'is-method flags) CLOS_IS_METHOD 0) + (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) + num-all-params + max-let-depth + (and tl-map + (if (tl-map . <= . #xFFFFFFF) + ;; Encode as a fixnum: + tl-map + ;; Encode as an even-sized vector of 16-bit integers: + (let ([len (* 2 (quotient (+ (integer-length tl-map) 31) 32))]) + (for/vector ([i (in-range len)]) + (let ([s (* i 16)]) + (bitwise-bit-field tl-map s (+ s 16))))))) + name + l) + out))])) + +(define (out-as-bytes expr ->bytes CPT len2 out #:before-length [before-length #f]) + (define s (->bytes expr)) + (out-byte CPT out) + (when before-length + (out-number before-length out)) + (out-number (bytes-length s) out) + (when len2 (out-number len2 out)) + (out-bytes s out)) + +(define-struct quoted (v)) + +(define (protect-quote v) + (if (or (pair? v) (vector? v) (and (not (zo? v)) (prefab-struct-key v)) (box? v) (hash? v) (svector? v)) + (make-quoted v) + v)) + +(define-struct svector (vec)) + +(define (make-relative v) + (let ([r (current-write-relative-directory)]) + (if r + (find-relative-path r v) + v))) + +(define (binding-namess-hash->list binding-namess) + (for/list ([(phase t) (in-hash binding-namess)]) + (cons phase + (list->vector + (apply append (for/list ([(id sym) (in-hash t)]) + (list id sym))))))) + +;; ---------------------------------------- + +;; We want to hash-cons syntax-object wraps, but a normal `equal?`-based +;; table would equate different "self" modidxes that we need to keep +;; separate. So, roll a `simple-equal?` that inspects wraps. We don't +;; have to deal with cycles, since cycles would always go through a scope, +;; and we recur into scopes. + +(struct modidx-must-be-eq (content) + #:property prop:equal+hash + (list (lambda (a b eql?) + (simple-equal? (modidx-must-be-eq-content a) + (modidx-must-be-eq-content b))) + (lambda (a h) (h (modidx-must-be-eq-content a))) + (lambda (a h) (h (modidx-must-be-eq-content a))))) + +(define (simple-equal? a b) + (cond + [(eqv? a b) #t] + [(pair? a) + (and (pair? b) + (simple-equal? (car a) (car b)) + (simple-equal? (cdr a) (cdr b)))] + [(vector? a) + (and (vector? b) + (= (vector-length a) (vector-length b)) + (for/and ([ae (in-vector a)] + [be (in-vector b)]) + (simple-equal? ae be)))] + [(box? a) + (and (box? b) + (simple-equal? (unbox a) (unbox b)))] + [(module-path-index? a) + (and (module-path-index? b) + (let-values ([(a-name a-base) (module-path-index-split a)] + [(b-name b-base) (module-path-index-split b)]) + (and a-name + a-base + (simple-equal? a-name b-name) + (simple-equal? a-base b-base))))] + [else #f])) + +(define (share-everywhere v out) + (define (register r) + (hash-set! (out-hash-consed-results out) r #t) + r) + (hash-ref! (out-hash-consed out) + (modidx-must-be-eq v) + (lambda () + (cond + [(pair? v) + (register + (cons (share-everywhere (car v) out) + (share-everywhere (cdr v) out)))] + [(vector? v) + (register + (for/vector #:length (vector-length v) ([e (in-vector v)]) + (share-everywhere e out)))] + [(box? v) + (register + (box (share-everywhere (unbox v) out)))] + [else v])))) + +;; ---------------------------------------- + +(define (encode-wrap w ht) + (hash-ref! ht w + (lambda () + (vector (map-encode encode-shift (wrap-shifts w) ht) + (encode-scope-list (wrap-simple-scopes w) ht) + (map-encode encode-multi-scope (wrap-multi-scopes w) ht))))) + +(define (map-encode encode l ht) + (cond + [(null? l) l] + [else + (hash-ref! ht l + (lambda () + (cons (encode (car l) ht) + (map-encode encode (cdr l) ht))))])) + +(define (encode-shift s ht) + (hash-ref! ht s + (lambda () + (if (module-shift-from-inspector-desc s) + (vector (module-shift-to s) + (module-shift-from s) + (module-shift-from-inspector-desc s) + (module-shift-to-inspector-desc s)) + (vector (module-shift-to s) + (module-shift-from s)))))) + +(define (encode-scope s ht) + (if (eq? 'root (scope-name s)) + s + (hash-ref ht s + (lambda () + (define es (encoded-scope (scope-name s) #f)) + (hash-set! ht s es) + (define kind + (case (scope-kind s) + [(module) (if (scope-multi-owner s) + 1 + 0)] + [(macro) 2] + [(local) 3] + [(intdef) 4] + [else 5])) + (cond + [(and (null? (scope-bindings s)) + (null? (scope-bulk-bindings s))) + (set-encoded-scope-content! es kind)] + [else + (define binding-table + (for/fold ([bt (hasheq)]) ([b (in-list (scope-bindings s))]) + (hash-set bt + (car b) + (cons (cons (encode-scope-list (cadr b) ht) + (encode-binding (caddr b) (car b) ht)) + (hash-ref bt (car b) null))))) + (define bindings + (list->vector + (apply + append + (sort (hash-map binding-table list) + symbol #:key (lambda (s) + (if (eq? 'root (scope-name s)) + -1 + (scope-name s)))) + ht)) + +(define (encode-multi-scope ms+phase ht) + (define ms (car ms+phase)) + (cons (hash-ref ht ms + (lambda () + (define v (make-vector (add1 (* 2 (length (multi-scope-scopes ms)))))) + (hash-set! ht ms v) + (vector-copy! + v + 0 + (list->vector + (append (apply + append + (for/list ([e (in-list (multi-scope-scopes ms))]) + (list (car e) + (encode-scope (cadr e) ht)))) + (list (multi-scope-src-name ms))))) + v)) + (cadr ms+phase))) + +(define (encode-binding b name ht) + (match b + [(free-id=?-binding base id phase) + (hash-ref ht b + (lambda () + (match b + [(free-id=?-binding base id phase) + (define bx (box #f)) + (hash-set! ht b bx) + (set-box! bx + (cons + (cons (encode-binding base name ht) + (cons (stx-obj-datum id) + (stx-obj-wrap id))) + phase))])))] + [_ + (hash-ref! ht b + (lambda () + (match b + [(local-binding name) + name] + [(module-binding encoded) + encoded] + [(? decoded-module-binding?) + (encode-module-binding b name ht)])))])) + + +(define (encode-module-binding b name ht) + (hash-ref! ht (cons name b) + (lambda () + (match b + [(decoded-module-binding path export-name phase + nominal-path nominal-export-name nominal-phase + import-phase inspector-desc) + (define l + (cond + [(and (eq? path nominal-path) + (eq? export-name nominal-export-name) + (eqv? phase 0) + (eqv? import-phase 0) + (eqv? nominal-phase phase)) + (if (eq? name export-name) + path + (cons path export-name))] + [(and (eq? export-name nominal-export-name) + (eq? name export-name) + (eqv? 0 phase) + (eqv? import-phase 0) + (eqv? nominal-phase phase)) + (cons path nominal-path)] + [else + (define nom-mod+phase + (if (eqv? nominal-phase phase) + (if (eqv? 0 import-phase) + nominal-path + (cons nominal-path import-phase)) + (cons nominal-path (cons import-phase nominal-phase)))) + (define l (list* export-name nom-mod+phase nominal-export-name)) + (if (zero? phase) + l + (cons phase l))])) + (if inspector-desc + (cons inspector-desc l) + l)])))) + +(define (encode-bulk-binding p ht) + (cons (encode-scope-list (car p) ht) + (encode-all-from-module (cadr p) ht))) + +(define (encode-all-from-module b ht) + (hash-ref! ht b + (lambda () + (match b + [(all-from-module path phase src-phase inspector-desc exceptions prefix) + (vector path src-phase + (cond + [(and (not prefix) (null? exceptions)) + phase] + [(not prefix) + (cons phase (list->vector exceptions))] + [(null? exceptions) + (cons phase prefix)] + [else + (cons phase (cons (list->vector exceptions) prefix))]) + inspector-desc)])))) + diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt new file mode 100644 index 0000000000..43b13a813c --- /dev/null +++ b/zo-lib/compiler/zo-parse.rkt @@ -0,0 +1,1506 @@ +#lang racket/base +(require racket/function + racket/match + racket/list + racket/struct + compiler/zo-structs + racket/dict + racket/set) + +(provide zo-parse + decode-module-binding) +(provide (all-from-out compiler/zo-structs)) + +;; ---------------------------------------- +;; Bytecode unmarshalers for various forms + +(define (read-toplevel v) + (define SCHEME_TOPLEVEL_CONST #x02) + (define SCHEME_TOPLEVEL_READY #x01) + (match v + [(cons depth (cons pos flags)) + ;; In the VM, the two flag bits are actually interpreted + ;; as a number when the toplevel is a reference, but we + ;; interpret the bits as flags here for backward compatibility. + (make-toplevel depth pos + (positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST)) + (positive? (bitwise-and flags SCHEME_TOPLEVEL_READY)))] + [(cons depth pos) + (make-toplevel depth pos #f #f)])) + +(define (read-topsyntax v) + (match v + [`(,depth ,pos . ,midpt) + (make-topsyntax depth pos midpt)])) + +(define (read-variable v) + (if (symbol? v) + (make-global-bucket v) + (error "expected a symbol"))) + +(define (do-not-read-variable v) + (error "should not get here")) + +(define (read-compilation-top v) + (match v + [`(,ld ,binding-namess ,prefix . ,code) + (unless (prefix? prefix) + (error 'bad "not prefix ~a" prefix)) + (make-compilation-top ld + (binding-namess-list->hash binding-namess) + prefix + code)])) + +(define (binding-namess-list->hash binding-namess) + (for/hash ([e (in-list binding-namess)]) + (values (car e) + (let ([vec (cdr e)]) + (for/hash ([i (in-range 0 (vector-length vec) 2)]) + (values (vector-ref vec i) + (vector-ref vec (add1 i)))))))) + +(define (read-resolve-prefix v) + (match v + [`(,src-insp-desc ,i ,tv . ,sv) + ;; XXX Why not leave them as vectors and change the contract? + (make-prefix i (vector->list tv) (vector->list sv) src-insp-desc)])) + +(define (read-unclosed-procedure v) + (define CLOS_HAS_REST 1) + (define CLOS_HAS_REF_ARGS 2) + (define CLOS_PRESERVES_MARKS 4) + (define CLOS_NEED_REST_CLEAR 8) + (define CLOS_IS_METHOD 16) + (define CLOS_SINGLE_RESULT 32) + (define BITS_PER_MZSHORT 32) + (define BITS_PER_ARG 4) + (match v + [`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest) + (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) + (let*-values ([(closure-size closed-over body) + (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) + (values (vector-length v) v rest) + (values v (car rest) (cdr rest)))] + [(get-flags) (lambda (i) + (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) + 0 + (let ([byte (vector-ref closed-over + (+ closure-size (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)))]) + (bitwise-and (arithmetic-shift byte (- (remainder (* BITS_PER_ARG i) BITS_PER_MZSHORT))) + (sub1 (arithmetic-shift 1 BITS_PER_ARG))))))] + [(num->type) (lambda (n) + (case n + [(2) 'flonum] + [(3) 'fixnum] + [(4) 'extflonum] + [else (error "invaid type flag")]))] + [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) + (for/list ([i (in-range num-params)]) + (define v (get-flags i)) + (case v + [(0) 'val] + [(1) 'ref] + [else (num->type v)])))] + [(closure-types) (for/list ([i (in-range closure-size)] + [j (in-naturals num-params)]) + (define v (get-flags j)) + (case v + [(0) 'val/ref] + [(1) (error "invalid 'ref closure variable")] + [else (num->type v)]))]) + (make-lam name + (append + (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) + (if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method)) + (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result)) + (if (zero? (bitwise-and flags flags CLOS_NEED_REST_CLEAR)) null '(sfs-clear-rest-args)) + (if (and rest? (zero? num-params)) '(only-rest-arg-not-used) null)) + (if (and rest? (num-params . > . 0)) + (sub1 num-params) + num-params) + arg-types + rest? + (if (= closure-size (vector-length closed-over)) + closed-over + (let ([v2 (make-vector closure-size)]) + (vector-copy! v2 0 closed-over 0 closure-size) + v2)) + closure-types + (and tl-map + (let* ([bits (if (exact-integer? tl-map) + tl-map + (for/fold ([i 0]) ([v (in-vector tl-map)] + [s (in-naturals)]) + (bitwise-ior i (arithmetic-shift v (* s 16)))))] + [len (integer-length bits)]) + (list->set + (let loop ([bit 0]) + (cond + [(bit . >= . len) null] + [(bitwise-bit-set? bits bit) + (cons bit (loop (add1 bit)))] + [else (loop (add1 bit))]))))) + max-let-depth + body)))])) + +(define (read-let-value v) + (match v + [`(,count ,pos ,boxes? ,rhs . ,body) + (make-install-value count pos boxes? rhs body)])) + +(define (read-let-void v) + (match v + [`(,count ,boxes? . ,body) + (make-let-void count boxes? body)])) + +(define (read-letrec v) + (match v + [`(,count ,body . ,procs) + (make-let-rec procs body)])) + +(define (read-with-cont-mark v) + (match v + [`(,key ,val . ,body) + (make-with-cont-mark key val body)])) + +(define (read-sequence v) + (make-seq v)) + +; XXX Allocates unnessary list +(define (read-define-values v) + (make-def-values + (cdr (vector->list v)) + (vector-ref v 0))) + +(define (read-define-syntax v) + (make-def-syntaxes (list-tail (vector->list v) 4) + (vector-ref v 0) + (vector-ref v 1) + (vector-ref v 2) + (vector-ref v 3))) + +(define (read-begin-for-syntax v) + (make-seq-for-syntax + (vector-ref v 0) + (vector-ref v 1) + (vector-ref v 2) + (vector-ref v 3))) + +(define (read-set! v) + (make-assign (cadr v) (cddr v) (car v))) + +(define (read-case-lambda v) + (make-case-lam (car v) (cdr v))) + +(define (read-begin0 v) + (make-beg0 v)) + +(define (read-boxenv v) + (make-boxenv (car v) (cdr v))) +(define (read-require v) + (make-req (cdr v) (car v))) +(define (read-#%variable-ref v) + (make-varref (car v) (cdr v))) +(define (read-apply-values v) + (make-apply-values (car v) (cdr v))) +(define (read-with-immed-mark v) + (make-with-immed-mark (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))) +(define (read-splice v) + (make-splice v)) + +(define (in-list* l n) + (make-do-sequence + (lambda () + (values (lambda (l) (apply values (take l n))) + (lambda (l) (drop l n)) + l + (lambda (l) (>= (length l) n)) + (lambda _ #t) + (lambda _ #t))))) + +(define (split-phase-data rest n) + (let loop ([n n] [rest rest] [phase-accum null]) + (cond + [(zero? n) + (values (reverse phase-accum) rest)] + [else + (let ([maybe-indirect (list-ref rest 1)]) + (if (void? maybe-indirect) + ;; no indirect or protect info: + (loop (sub1 n) + (list-tail rest 9) + (cons (take rest 9) phase-accum)) + ;; has indirect or protect info: + (loop (sub1 n) + (list-tail rest (+ 5 8)) + (cons (take rest (+ 5 8)) phase-accum))))]))) + +(define (read-module v) + (match v + [`(,submod-path + ,name ,srcname ,self-modidx + ,rt-binding-names ,et-binding-names ,other-binding-names + ,cross-phase? + ,pre-submods ,post-submods + ,lang-info ,functional? ,et-functional? + ,rename ,max-let-depth ,dummy + ,prefix ,num-phases + ,provide-phase-count . ,rest) + (let*-values ([(phase-data rest-module) (split-phase-data rest provide-phase-count)] + [(bodies rest-module) (values (take rest-module num-phases) + (drop rest-module num-phases))]) + (match rest-module + [`(,requires ,syntax-requires ,template-requires ,label-requires + ,more-requires-count . ,more-requires) + (make-mod (if (null? submod-path) + name + (if (symbol? name) + (cons name submod-path) + (cons (car name) submod-path))) + srcname self-modidx + prefix + ;; provides: + (for/list ([l (in-list phase-data)]) + (let* ([phase (list-ref l 0)] + [has-info? (not (void? (list-ref l 1)))] + [delta (if has-info? 5 1)] + [num-vars (list-ref l (+ delta 6))] + [num-all (list-ref l (+ delta 7))] + [ps (for/list ([name (in-vector (list-ref l (+ delta 5)))] + [src (in-vector (list-ref l (+ delta 4)))] + [src-name (in-vector (list-ref l (+ delta 3)))] + [nom-src (or (list-ref l (+ delta 2)) + (in-cycle (in-value #f)))] + [src-phase (or (list-ref l (+ delta 1)) + (in-cycle (in-value 0)))] + [protected? (cond + [(or (not has-info?) + (not (list-ref l 5))) + (in-cycle (in-value #f))] + [else (list-ref l 5)])]) + (make-provided name src src-name + (or nom-src src) + src-phase + protected?))]) + (list + phase + (take ps num-vars) + (drop ps num-vars)))) + ;; requires: + (list* + (cons 0 requires) + (cons 1 syntax-requires) + (cons -1 template-requires) + (cons #f label-requires) + (for/list ([(phase reqs) (in-list* more-requires 2)]) + (cons phase reqs))) + ;; body: + (vector->list (last bodies)) + ;; syntax-bodies: add phase to each list, break apart + (for/list ([b (cdr (reverse bodies))] + [i (in-naturals 1)]) + (cons i + (for/list ([sb (in-vector b)]) + (match sb + [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?) + (if for-stx? + (make-seq-for-syntax (list expr) prefix max-let-depth #f) + (make-def-syntaxes + (if (list? ids) ids (list ids)) expr prefix max-let-depth #f))] + [else (error 'zo-parse "bad phase ~a body element: ~e" i sb)])))) + ;; unexported: + (for/list ([l (in-list phase-data)] + #:unless (void? (list-ref l 1))) + (let* ([phase (list-ref l 0)] + [indirect-syntax + ;; could check: (list-ref l 2) should be size of vector: + (list-ref l 1)] + [indirect + ;; could check: (list-ref l 4) should be size of vector: + (list-ref l 3)]) + (list + phase + (vector->list indirect) + (vector->list indirect-syntax)))) + max-let-depth + dummy + lang-info + rename + (assemble-binding-names rt-binding-names + et-binding-names + other-binding-names) + (if cross-phase? '(cross-phase) '()) + (map read-module pre-submods) + (map read-module post-submods))]))])) +(define (read-module-wrap v) + v) + + +(define (read-inline-variant v) + (make-inline-variant (car v) (cdr v))) + +(define (assemble-binding-names rt-binding-names + et-binding-names + other-binding-names) + (define (vector-to-ht vec) + (define sz (vector-length vec)) + (let loop ([i 0] [ht #hasheq()]) + (cond + [(= i sz) ht] + [else (loop (+ i 2) + (hash-set ht (vector-ref vec i) (vector-ref vec (add1 i))))]))) + (for/hash ([(phase vec) (let* ([ht (if other-binding-names + (vector-to-ht other-binding-names) + #hash())] + [ht (if rt-binding-names + (hash-set ht 0 rt-binding-names) + ht)] + [ht (if et-binding-names + (hash-set ht 0 et-binding-names) + ht)]) + ht)]) + (values phase (vector-to-ht vec)))) + +;; ---------------------------------------- +;; Unmarshal dispatch for various types + +;; Type mappings from "stypes.h": +(define (int->type i) + (case i + [(0) 'toplevel-type] + [(6) 'sequence-type] + [(8) 'unclosed-procedure-type] + [(9) 'let-value-type] + [(10) 'let-void-type] + [(11) 'letrec-type] + [(13) 'with-cont-mark-type] + [(14) 'quote-syntax-type] + [(15) 'define-values-type] + [(16) 'define-syntaxes-type] + [(17) 'begin-for-syntax-type] + [(18) 'set-bang-type] + [(19) 'boxenv-type] + [(20) 'begin0-sequence-type] + [(21) 'splice-sequence-type] + [(22) 'require-form-type] + [(23) 'varref-form-type] + [(24) 'apply-values-type] + [(25) 'with-immed-mark-type] + [(26) 'case-lambda-sequence-type] + [(27) 'module-type] + [(28) 'inline-variant-type] + [(37) 'variable-type] + [(38) 'module-variable-type] + [(122) 'resolve-prefix-type] + [else (error 'int->type "unknown type: ~e" i)])) + +(define type-readers + (make-immutable-hash + (list + (cons 'toplevel-type read-toplevel) + (cons 'sequence-type read-sequence) + (cons 'unclosed-procedure-type read-unclosed-procedure) + (cons 'let-value-type read-let-value) + (cons 'let-void-type read-let-void) + (cons 'letrec-type read-letrec) + (cons 'with-cont-mark-type read-with-cont-mark) + (cons 'quote-syntax-type read-topsyntax) + (cons 'variable-type read-variable) + (cons 'module-variable-type do-not-read-variable) + (cons 'compilation-top-type read-compilation-top) + (cons 'case-lambda-sequence-type read-case-lambda) + (cons 'begin0-sequence-type read-begin0) + (cons 'module-type read-module) + (cons 'inline-variant-type read-inline-variant) + (cons 'resolve-prefix-type read-resolve-prefix) + (cons 'define-values-type read-define-values) + (cons 'define-syntaxes-type read-define-syntax) + (cons 'begin-for-syntax-type read-begin-for-syntax) + (cons 'set-bang-type read-set!) + (cons 'boxenv-type read-boxenv) + (cons 'require-form-type read-require) + (cons 'varref-form-type read-#%variable-ref) + (cons 'apply-values-type read-apply-values) + (cons 'with-immed-mark-type read-with-immed-mark) + (cons 'splice-sequence-type read-splice)))) + +(define (get-reader type) + (hash-ref type-readers type + (λ () + (error 'read-marshalled "reader for ~a not implemented" type)))) + +;; ---------------------------------------- +;; Lowest layer of bytecode parsing + +(define (split-so all-short so) + (define n (if (zero? all-short) 4 2)) + (let loop ([so so]) + (if (zero? (bytes-length so)) + null + (cons (integer-bytes->integer (subbytes so 0 n) #f #f) + (loop (subbytes so n)))))) + +(define (read-simple-number p) + (integer-bytes->integer (read-bytes 4 p) #f #f)) + +(define-struct cport ([pos #:mutable] shared-start orig-port size bytes-start symtab shared-offsets decoded rns mpis)) +(define (cport-get-bytes cp len) + (define port (cport-orig-port cp)) + (define pos (cport-pos cp)) + (file-position port (+ (cport-bytes-start cp) pos)) + (read-bytes len port)) +(define (cport-get-byte cp pos) + (define port (cport-orig-port cp)) + (file-position port (+ (cport-bytes-start cp) pos)) + (read-byte port)) + +(define (cport-rpos cp) + (+ (cport-pos cp) (cport-shared-start cp))) + +(define (cp-getc cp) + (when ((cport-pos cp) . >= . (cport-size cp)) + (error "off the end")) + (define r (cport-get-byte cp (cport-pos cp))) + (set-cport-pos! cp (add1 (cport-pos cp))) + r) + +(define small-list-max 50) +(define raw-cpt-table + ;; The "schcpt.h" mapping, earlier entries override later ones + `([0 escape] + [1 symbol] + [2 symref] + [3 weird-symbol] + [4 keyword] + [5 byte-string] + [6 string] + [7 char] + [8 int] + [9 null] + [10 true] + [11 false] + [12 void] + [13 box] + [14 pair] + [15 list] + [16 vector] + [17 hash-table] + [18 stx] + [19 let-one-typed] + [20 marshalled] + [21 quote] + [22 reference] + [23 local] + [24 local-unbox] + [25 svector] + [26 application] + [27 let-one] + [28 branch] + [29 module-index] + [30 module-var] + [31 path] + [32 closure] + [33 delayed] + [34 prefab] + [35 let-one-unused] + [36 scope] + [37 root-scope] + [38 shared] + [39 62 small-number] + [62 80 small-symbol] + [80 92 small-marshalled] + [92 ,(+ 92 small-list-max) small-proper-list] + [,(+ 92 small-list-max) 192 small-list] + [192 207 small-local] + [207 222 small-local-unbox] + [222 247 small-svector] + [248 small-application2] + [249 small-application3] + [247 255 small-application])) + +(define root-scope (scope 'root 'module null null #f)) + +;; To accelerate cpt-table lookup, we flatten out the above +;; list into a vector: +(define cpt-table (make-vector 256 #f)) +(for ([ent (in-list (reverse raw-cpt-table))]) + ;; reverse order so that early entries override later ones. + (match ent + [(list k sym) (vector-set! cpt-table k (cons k sym))] + [(list k k* sym) (for ([i (in-range k k*)]) + (vector-set! cpt-table i (cons k sym)))])) + +(define (read-compact-bytes port c) + (begin0 + (cport-get-bytes port c) + (set-cport-pos! port (+ c (cport-pos port))))) + +(define (read-compact-chars port c) + (bytes->string/utf-8 (read-compact-bytes port c))) + +(define (read-compact-list c proper port) + (cond [(= 0 c) + (if proper null (read-compact port))] + [else (cons (read-compact port) (read-compact-list (sub1 c) proper port))])) + +(define (read-compact-number port) + (define flag (cp-getc port)) + (cond [(< flag 128) + flag] + [(zero? (bitwise-and flag #x40)) + (let ([a (cp-getc port)]) + (+ (a . << . 6) (bitwise-and flag 63)))] + [(zero? (bitwise-and flag #x20)) + (- (bitwise-and flag #x1F))] + [else + (let ([a (cp-getc port)] + [b (cp-getc port)] + [c (cp-getc port)] + [d (cp-getc port)]) + (let ([n (integer-bytes->integer (bytes a b c d) #f #f)]) + (if (zero? (bitwise-and flag #x10)) + (- n) + n)))])) + +(define (read-compact-svector port n) + (define v (make-vector n)) + (for ([i (in-range n)]) + (vector-set! v (sub1 (- n i)) (read-compact-number port))) + v) + +(define (read-marshalled type port) + (let* ([type (if (number? type) (int->type type) type)] + [l (read-compact port)] + [reader (get-reader type)]) + (reader l))) + +(define SCHEME_LOCAL_TYPE_FLONUM 1) +(define SCHEME_LOCAL_TYPE_FIXNUM 2) +(define SCHEME_LOCAL_TYPE_EXTFLONUM 3) + +(define (make-local unbox? pos flags) + (define SCHEME_LOCAL_CLEAR_ON_READ 1) + (define SCHEME_LOCAL_OTHER_CLEARS 2) + (define SCHEME_LOCAL_TYPE_OFFSET 2) + (make-localref unbox? pos + (= flags SCHEME_LOCAL_CLEAR_ON_READ) + (= flags SCHEME_LOCAL_OTHER_CLEARS) + (let ([t (- flags SCHEME_LOCAL_TYPE_OFFSET)]) + (cond + [(= t SCHEME_LOCAL_TYPE_FLONUM) 'flonum] + [(= t SCHEME_LOCAL_TYPE_EXTFLONUM) 'extflonum] + [(= t SCHEME_LOCAL_TYPE_FIXNUM) 'fixnum] + [else #f])))) + +(define (a . << . b) + (arithmetic-shift a b)) + +(define-struct not-ready ()) +(define-struct in-progress ()) + +;; ---------------------------------------- +;; Syntax unmarshaling +(define (make-memo) (make-weak-hash)) +(define (with-memo* mt arg thnk) + (hash-ref! mt arg thnk)) +(define-syntax-rule (with-memo mt arg body ...) + (with-memo* mt arg (λ () body ...))) + +;; placeholder for a `scope` decoded in a second pass: +(struct encoded-scope (relative-id content) #:prefab) + +(define (decode-wrapped cp v) + (let loop ([v v]) + (let-values ([(tamper-status v encoded-wraps esrcloc) + (match v + [`#(,datum ,wraps 1) (values 'tainted datum wraps #f)] + [`#(,datum ,wraps 2) (values 'armed datum wraps #f)] + [`#(,datum ,wraps ,esrcloc 1) (values 'tainted datum wraps esrcloc)] + [`#(,datum ,wraps ,esrcloc 2) (values 'armed datum wraps esrcloc)] + [`#(,datum ,wraps ,esrcloc) (values 'clean datum wraps esrcloc)] + [`(,datum . ,wraps) (values 'clean datum wraps #f)] + [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) + (let* ([wrapped-memo (make-memo)] + [add-wrap (lambda (v) (with-memo wrapped-memo v (make-stx-obj v encoded-wraps esrcloc #hasheq() tamper-status)))]) + (cond + [(pair? v) + (if (eq? #t (car v)) + ;; Share decoded wraps with all nested parts. + (let iloop ([v (cdr v)]) + (cond + [(pair? v) + (let ploop ([v v]) + (cond + [(null? v) null] + [(pair? v) (add-wrap (cons (iloop (car v)) (ploop (cdr v))))] + [else (iloop v)]))] + [(box? v) (add-wrap (box (iloop (unbox v))))] + [(vector? v) + (add-wrap (list->vector (map iloop (vector->list v))))] + [(hash? v) + (add-wrap (for/hash ([(k v) (in-hash v)]) + (values k (iloop v))))] + [(prefab-struct-key v) + => (lambda (k) + (add-wrap + (apply + make-prefab-struct + k + (map iloop (struct->list v)))))] + [else (add-wrap v)])) + ;; Decode sub-elements that have their own wraps: + (let-values ([(v counter) (if (exact-integer? (car v)) + (values (cdr v) (car v)) + (values v -1))]) + (add-wrap + (let ploop ([v v][counter counter]) + (cond + [(null? v) null] + [(or (not (pair? v)) (zero? counter)) (loop v)] + [(pair? v) (cons (loop (car v)) + (ploop (cdr v) (sub1 counter)))])))))] + [(box? v) (add-wrap (box (loop (unbox v))))] + [(vector? v) + (add-wrap (list->vector (map loop (vector->list v))))] + [(hash? v) + (add-wrap (for/hash ([(k v) (in-hash v)]) + (values k (loop v))))] + [(prefab-struct-key v) + => (lambda (k) + (add-wrap + (apply + make-prefab-struct + k + (map loop (struct->list v)))))] + [else (add-wrap v)]))))) + +(define (in-vector* v n) + (make-do-sequence + (λ () + (values (λ (i) (vector->values v i (+ i n))) + (λ (i) (+ i n)) + 0 + (λ (i) (>= (vector-length v) (+ i n))) + (λ _ #t) + (λ _ #t))))) + +(define (parse-module-path-index cp s) + s) + +;; ---------------------------------------- +;; Main parsing loop + +(define (read-compact cp) + (let loop ([need-car 0] [proper #f]) + (define ch (cp-getc cp)) + (define-values (cpt-start cpt-tag) + (let ([x (vector-ref cpt-table ch)]) + (unless x (error 'read-compact "unknown code : ~a" ch)) + (values (car x) (cdr x)))) + (define v + (case cpt-tag + [(delayed) + (let ([pos (read-compact-number cp)]) + (read-symref cp pos #t 'delayed))] + [(escape) + (let* ([len (read-compact-number cp)] + [s (cport-get-bytes cp len)]) + (set-cport-pos! cp (+ (cport-pos cp) len)) + (parameterize ([read-accept-compiled #t] + [read-accept-bar-quote #t] + [read-accept-box #t] + [read-accept-graph #t] + [read-case-sensitive #t] + [read-square-bracket-as-paren #t] + [read-curly-brace-as-paren #t] + [read-decimal-as-inexact #t] + [read-accept-dot #t] + [read-accept-infix-dot #t] + [read-accept-quasiquote #t] + [current-readtable + (make-readtable + #f + #\^ + 'dispatch-macro + (lambda (char port src line col pos) + (let ([b (read port)]) + (unless (bytes? b) + (error 'read-escaped-path + "expected a byte string after #^")) + (let ([p (bytes->path b)]) + (if (and (relative-path? p) + (current-load-relative-directory)) + (build-path (current-load-relative-directory) p) + p)))))]) + (read/recursive (open-input-bytes s))))] + [(reference) + (make-primval (read-compact-number cp))] + [(small-list small-proper-list) + (let* ([l (- ch cpt-start)] + [ppr (eq? cpt-tag 'small-proper-list)]) + (if (positive? need-car) + (if (= l 1) + (cons (read-compact cp) + (if ppr null (read-compact cp))) + (read-compact-list l ppr cp)) + (loop l ppr)))] + [(let-one let-one-typed let-one-unused) + (make-let-one (read-compact cp) (read-compact cp) + (and (eq? cpt-tag 'let-one-typed) + (case (read-compact-number cp) + [(1) 'flonum] + [(2) 'fixnum] + [(3) 'extflonum] + [else #f])) + (eq? cpt-tag 'let-one-unused))] + [(branch) + (make-branch (read-compact cp) (read-compact cp) (read-compact cp))] + [(module-index) + (define name (read-compact cp)) + (define base (read-compact cp)) + (if (or name base) + (module-path-index-join name base) + (module-path-index-join #f #f (read-compact cp)))] + [(module-var) + (let ([mod (read-compact cp)] + [var (read-compact cp)] + [shape (read-compact cp)] + [pos (read-compact-number cp)]) + (let-values ([(flags mod-phase pos) + (let loop ([pos pos]) + (cond + [(pos . < . -3) + (let ([real-pos (read-compact-number cp)]) + (define-values (_ m p) (loop real-pos)) + (values (- (+ pos 3)) m p))] + [(= pos -2) + (values 0 (read-compact-number cp) (read-compact-number cp))] + [else (values 0 0 pos)]))]) + (make-module-variable mod var pos mod-phase + (cond + [shape + (cond + [(number? shape) + (define n (arithmetic-shift shape -1)) + (make-function-shape (if (negative? n) + (make-arity-at-least (sub1 (- n))) + n) + (odd? shape))] + [(and (symbol? shape) + (regexp-match? #rx"^struct" (symbol->string shape))) + (define n (string->number (substring (symbol->string shape) 6))) + (case (bitwise-and n #x7) + [(0) (make-struct-type-shape (arithmetic-shift n -3))] + [(1) (make-constructor-shape (arithmetic-shift n -3))] + [(2) (make-predicate-shape)] + [(3) (make-accessor-shape (arithmetic-shift n -3))] + [(4) (make-mutator-shape (arithmetic-shift n -3))] + [else (make-struct-other-shape)])] + [else + ;; parse symbol as ":"-separated sequence of arities + (make-function-shape + (for/list ([s (regexp-split #rx":" (symbol->string shape))]) + (define i (string->number s)) + (if (negative? i) + (make-arity-at-least (sub1 (- i))) + i)) + #f)])] + [(not (zero? (bitwise-and #x1 flags))) 'constant] + [(not (zero? (bitwise-and #x2 flags))) 'fixed] + [else #f]))))] + [(local-unbox) + (let* ([p* (read-compact-number cp)] + [p (if (< p* 0) (- (add1 p*)) p*)] + [flags (if (< p* 0) (read-compact-number cp) 0)]) + (make-local #t p flags))] + [(path) + (let ([len (read-compact-number cp)]) + (if (zero? len) + ;; Read a list of byte strings as relative path elements: + (let ([p (or (current-load-relative-directory) + (current-directory))]) + (for/fold ([p p]) ([e (in-list (read-compact cp))]) + (build-path p (if (bytes? e) (bytes->path-element e) e)))) + ;; Read a path: + (bytes->path (read-compact-bytes cp len))))] + [(small-number) + (let ([l (- ch cpt-start)]) + l)] + [(int) + (read-compact-number cp)] + [(false) #f] + [(true) #t] + [(null) null] + [(void) (void)] + [(vector) + ; XXX We should provide build-immutable-vector and write this as: + #;(build-immutable-vector (read-compact-number cp) + (lambda (i) (read-compact cp))) + ; XXX Now it allocates an unnessary list AND vector + (let* ([n (read-compact-number cp)] + [lst (for/list ([i (in-range n)]) (read-compact cp))]) + (vector->immutable-vector (list->vector lst)))] + [(pair) + (let* ([a (read-compact cp)] + [d (read-compact cp)]) + (cons a d))] + [(list) + (let ([len (read-compact-number cp)]) + (let loop ([i len]) + (if (zero? i) + (read-compact cp) + (list* (read-compact cp) + (loop (sub1 i))))))] + [(prefab) + (let ([v (read-compact cp)]) + ; XXX This is faster than apply+->list, but can we avoid allocating the vector? + (call-with-values (lambda () (vector->values v)) + make-prefab-struct))] + [(hash-table) + ; XXX Allocates an unnessary list (maybe use for/hash(eq)) + (let ([eq (read-compact-number cp)] + [len (read-compact-number cp)]) + ((case eq + [(0) make-hasheq-placeholder] + [(1) make-hash-placeholder] + [(2) make-hasheqv-placeholder]) + (for/list ([i (in-range len)]) + (cons (read-compact cp) + (read-compact cp)))))] + [(marshalled) (read-marshalled (read-compact-number cp) cp)] + [(stx) + (let ([v (read-compact cp)]) + (make-stx (decode-wrapped cp v)))] + [(local local-unbox) + (let ([c (read-compact-number cp)] + [unbox? (eq? cpt-tag 'local-unbox)]) + (if (negative? c) + (make-local unbox? (- (add1 c)) (read-compact-number cp)) + (make-local unbox? c 0)))] + [(small-local) + (make-local #f (- ch cpt-start) 0)] + [(small-local-unbox) + (make-local #t (- ch cpt-start) 0)] + [(small-symbol) + (let ([l (- ch cpt-start)]) + (string->symbol (read-compact-chars cp l)))] + [(symbol) + (let ([l (read-compact-number cp)]) + (string->symbol (read-compact-chars cp l)))] + [(keyword) + (let ([l (read-compact-number cp)]) + (string->keyword (read-compact-chars cp l)))] + [(byte-string) + (let ([l (read-compact-number cp)]) + (read-compact-bytes cp l))] + [(string) + (let ([l (read-compact-number cp)] + [cl (read-compact-number cp)]) + (read-compact-chars cp l))] + [(char) + (integer->char (read-compact-number cp))] + [(box) + (box (read-compact cp))] + [(quote) + (make-reader-graph + ;; Nested escapes need to share graph references. So get inside the + ;; read where `read/recursive' can be used: + (let ([rt (current-readtable)]) + (parameterize ([current-readtable (make-readtable + #f + #\x 'terminating-macro + (lambda args + (parameterize ([current-readtable rt]) + (read-compact cp))))]) + (read (open-input-bytes #"x")))))] + [(symref) + (let* ([l (read-compact-number cp)]) + (read-symref cp l #t 'symref))] + [(weird-symbol) + (let ([uninterned (read-compact-number cp)] + [str (read-compact-chars cp (read-compact-number cp))]) + (if (= 1 uninterned) + ; uninterned is equivalent to weird in the C implementation + (string->uninterned-symbol str) + ; unreadable is equivalent to parallel in the C implementation + (string->unreadable-symbol str)))] + [(small-marshalled) + (read-marshalled (- ch cpt-start) cp)] + [(small-application2) + (make-application (read-compact cp) + (list (read-compact cp)))] + [(small-application3) + (make-application (read-compact cp) + (list (read-compact cp) + (read-compact cp)))] + [(small-application) + (let ([c (add1 (- ch cpt-start))]) + (make-application (read-compact cp) + (for/list ([i (in-range (sub1 c))]) + (read-compact cp))))] + [(application) + (let ([c (read-compact-number cp)]) + (make-application (read-compact cp) + (for/list ([i (in-range c)]) + (read-compact cp))))] + [(closure) + (define pos (read-compact-number cp)) + (define ph (make-placeholder 'closure)) + (symtab-write! cp pos ph) + (define v (read-compact cp)) + (define r + (make-closure + v + (gensym + (let ([s (lam-name v)]) + (cond + [(symbol? s) s] + [(vector? s) (vector-ref s 0)] + [else 'closure]))))) + (placeholder-set! ph r) + r] + [(svector) + (read-compact-svector cp (read-compact-number cp))] + [(small-svector) + (read-compact-svector cp (- ch cpt-start))] + [(scope) + (let ([pos (read-compact-number cp)] + [relative-id (read-compact-number cp)]) + (if (zero? pos) + (encoded-scope relative-id (read-compact cp)) + (read-cyclic cp pos 'scope (lambda (v) + (encoded-scope relative-id + v)))))] + [(root-scope) + root-scope] + [(shared) + (let ([pos (read-compact-number cp)]) + (read-cyclic cp pos 'shared))] + [else (error 'read-compact "unknown tag ~a" cpt-tag)])) + (cond + [(zero? need-car) v] + [(and proper (= need-car 1)) + (cons v null)] + [else + (cons v (loop (sub1 need-car) proper))]))) + +(define (symtab-write! cp i v) + (vector-set! (cport-symtab cp) i v)) + +(define (symtab-lookup cp i) + (vector-ref (cport-symtab cp) i)) + +(define (read-cyclic cp i who [wrap values]) + (define ph (make-placeholder (not-ready))) + (symtab-write! cp i ph) + (define r (wrap (read-compact cp))) + (when (eq? r ph) (error who "unresolvable cyclic data")) + (placeholder-set! ph r) + ph) + +(define (read-symref cp i mark-in-progress? who) + (define v (symtab-lookup cp i)) + (cond + [(not-ready? v) + (when mark-in-progress? + (symtab-write! cp i (in-progress))) + (define save-pos (cport-pos cp)) + (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i))) + (define v (read-compact cp)) + (symtab-write! cp i v) + (set-cport-pos! cp save-pos) + v] + [(in-progress? v) + (error who "unexpected cycle in input")] + [else v])) + +(define (read-prefix port) + ;; skip the "#~" + (unless (equal? #"#~" (read-bytes 2 port)) + (error 'zo-parse "not a bytecode stream")) + + (define version (read-bytes (min 63 (read-byte port)) port)) + + (read-char port)) + +;; path -> bytes +;; implementes read.c:read_compiled +(define (zo-parse [port (current-input-port)]) + (define init-pos (file-position port)) + + (define mode (read-prefix port)) + + (case mode + [(#\T) (zo-parse-top port)] + [(#\D) + (struct mod-info (name start len)) + (define mod-infos + (sort + (for/list ([i (in-range (read-simple-number port))]) + (define size (read-simple-number port)) + (define name (read-bytes size port)) + (define start (read-simple-number port)) + (define len (read-simple-number port)) + (define left (read-simple-number port)) + (define right (read-simple-number port)) + (define name-p (open-input-bytes name)) + (mod-info (let loop () + (define c (read-byte name-p)) + (if (eof-object? c) + null + (cons (string->symbol + (bytes->string/utf-8 (read-bytes (if (= c 255) + (read-simple-number port) + c) + name-p))) + (loop)))) + start + len)) + < + #:key mod-info-start)) + (define tops + (for/list ([mod-info (in-list mod-infos)]) + (define pos (file-position port)) + (unless (= (- pos init-pos) (mod-info-start mod-info)) + (error 'zo-parse + "next module expected at ~a, currently at ~a" + (+ init-pos (mod-info-start mod-info)) pos)) + (unless (eq? (read-prefix port) #\T) + (error 'zo-parse "expected a module")) + (define top (zo-parse-top port #f)) + (define m (compilation-top-code top)) + (unless (mod? m) + (error 'zo-parse "expected a module")) + (unless (equal? (mod-info-name mod-info) + (if (symbol? (mod-name m)) + '() + (cdr (mod-name m)))) + (error 'zo-parse "module name mismatch")) + top)) + (define avail (for/hash ([mod-info (in-list mod-infos)] + [top (in-list tops)]) + (values (mod-info-name mod-info) top))) + (unless (hash-ref avail '() #f) + (error 'zo-parse "no root module in directory")) + (define-values (pre-subs post-subs seen) + (for/fold ([pre-subs (hash)] [post-subs (hash)] [seen (hash)]) ([mod-info (in-list mod-infos)]) + (if (null? (mod-info-name mod-info)) + (values pre-subs post-subs (hash-set seen '() #t)) + (let () + (define name (mod-info-name mod-info)) + (define prefix (take name (sub1 (length name)))) + (unless (hash-ref avail prefix #f) + (error 'zo-parse "no parent module for ~s" name)) + (define (add subs) + (hash-set subs prefix (cons name (hash-ref subs prefix '())))) + (define new-seen (hash-set seen name #t)) + (if (hash-ref seen prefix #f) + (values pre-subs (add post-subs) new-seen) + (values (add pre-subs) post-subs new-seen)))))) + (define (get-all prefix) + (struct-copy mod + (compilation-top-code (hash-ref avail prefix)) + [pre-submodules (map get-all (reverse (hash-ref pre-subs prefix '())))] + [post-submodules (map get-all (reverse (hash-ref post-subs prefix '())))])) + (struct-copy compilation-top (hash-ref avail '()) + [code (get-all '())])] + [else + (error 'zo-parse "bad file format specifier")])) + +(define (zo-parse-top [port (current-input-port)] [check-end? #t]) + + ;; Skip module hash code + (read-bytes 20 port) + + (define symtabsize (read-simple-number port)) + + (define all-short (read-byte port)) + + (define cnt (* (if (not (zero? all-short)) 2 4) + (sub1 symtabsize))) + + (define so (read-bytes cnt port)) + + (define so* (list->vector (split-so all-short so))) + + (define shared-size (read-simple-number port)) + (define size* (read-simple-number port)) + + (when (shared-size . >= . size*) + (error 'zo-parse "Non-shared data segment start is not after shared data segment (according to offsets)")) + + (define rst-start (file-position port)) + + (file-position port (+ rst-start size*)) + + (when check-end? + (unless (eof-object? (read-byte port)) + (error 'zo-parse "File too big"))) + + (define symtab (make-vector symtabsize (not-ready))) + + (define cp + (make-cport 0 shared-size port size* rst-start symtab so* + (make-vector symtabsize (not-ready)) (make-hash) (make-hash))) + + (for ([i (in-range 1 symtabsize)]) + (read-symref cp i #f 'table)) + + #;(printf "Parsed table:\n") + #;(for ([(i v) (in-dict (cport-symtab cp))]) + (printf "~a = ~a\n" i (placeholder-get v))) + (set-cport-pos! cp shared-size) + + (define decoded-except-for-stx + (make-reader-graph (read-marshalled 'compilation-top-type cp))) + + (decode-stxes decoded-except-for-stx)) + +;; ---------------------------------------- + +(define (decode-stxes v) + ;; Walk `v` to find `stx-obj` instances and decode the `wrap` field. + ;; We do this after building a graph from the input, and `decode-wrap` + ;; preserves graph structure. + (define decode-ht (make-hasheq)) + (define srcloc-ht (make-hasheq)) + (let walk ([p v]) + (match p + [(compilation-top _ binding-namess pfx c) + (struct-copy compilation-top p + [binding-namess (walk binding-namess)] + [prefix (walk pfx)] + [code (walk c)])] + [(prefix _ _ s _) + (struct-copy prefix p [stxs (map walk s)])] + [(req rs _) + (struct-copy req p + [reqs (walk rs)])] + [(? mod?) + (struct-copy mod p + [prefix (walk (mod-prefix p))] + [syntax-bodies + (for/list ([e (in-list (mod-syntax-bodies p))]) + (cons (car e) + (map walk (cdr e))))] + [internal-context + (walk (mod-internal-context p))] + [binding-names + (for/hash ([(p ht) (in-hash (mod-binding-names p))]) + (values p + (for/hash ([(k v) (in-hash ht)]) + (values k (walk v)))))] + [pre-submodules + (map walk (mod-pre-submodules p))] + [post-submodules + (map walk (mod-post-submodules p))])] + [(stx c) + (struct-copy stx p [content (walk c)])] + [(def-syntaxes _ _ pfx _ _) + (struct-copy def-syntaxes p + [prefix (walk pfx)])] + [(seq-for-syntax _ pfx _ _) + (struct-copy seq-for-syntax p + [prefix (walk pfx)])] + [(stx-obj d w esrcloc _ _) + (define-values (srcloc props) (decode-srcloc+props esrcloc srcloc-ht)) + (struct-copy stx-obj p + [datum (walk d)] + [wrap (decode-wrap w decode-ht)] + [srcloc srcloc] + [props props])] + [(? zo?) p] + ;; Generic constructors happen inside the `datum` of `stx-obj`, + ;; for example (with no cycles): + [(cons a d) + (cons (walk a) (walk d))] + [(? vector?) + (vector->immutable-vector + (for/vector #:length (vector-length p) ([e (in-vector p)]) + (walk e)))] + [(box v) + (box-immutable (walk v))] + [(? prefab-struct-key) + (apply make-prefab-struct + (prefab-struct-key p) + (cdr (for/list ([e (in-vector (struct->vector p))]) + (walk e))))] + [(? hash?) + (cond + [(hash-eq? p) + (for/hasheq ([(k v) (in-hash p)]) + (values k (walk v)))] + [(hash-eqv? p) + (for/hasheqv ([(k v) (in-hash p)]) + (values k (walk v)))] + [else + (for/hash ([(k v) (in-hash p)]) + (values k (walk v)))])] + [_ p]))) + +;; ---------------------------------------- + +(define (decode-srcloc+props esrcloc ht) + (define (norm v) (if (v . < . 0) #f v)) + (define p + (hash-ref! ht + esrcloc + (lambda () + (cons (and esrcloc + ;; We could reduce this srcloc to #f if + ;; there's no source, line, column, or position + ;; information, but we want to expose the actual + ;; content of a bytecode stream: + (srcloc (vector-ref esrcloc 0) + (norm (vector-ref esrcloc 1)) + (norm (vector-ref esrcloc 2)) + (norm (vector-ref esrcloc 3)) + (norm (vector-ref esrcloc 4)))) + (let ([props + (if (and esrcloc ((vector-length esrcloc) . > . 5)) + (case (vector-ref esrcloc 5) + [(#\[) #hasheq((paren-shape . #\[))] + [(#\{) #hasheq((paren-shape . #\{))] + [else #hasheq()]) + #hasheq())]) + (if (and esrcloc ((vector-length esrcloc) . > . 6)) + (for/fold ([props props]) ([p (in-list (vector-ref esrcloc 6))]) + (hash-set props (car p) (cdr p))) + props)))))) + (values (car p) (cdr p))) + +;; ---------------------------------------- + +(define (decode-wrap encoded-wrap ht) + (hash-ref! ht + encoded-wrap + (lambda () + (match encoded-wrap + [(vector shifts simple-scopes multi-scopes) + (make-wrap (decode-map decode-shift shifts ht) + (decode-map decode-scope simple-scopes ht) + (decode-map decode-shifted-multi-scope multi-scopes ht))] + [_ (error 'decode-wrap "bad wrap")])))) + +(define (decode-map decode-one l ht) + (cond + [(null? l) l] + [(not (pair? l)) + (error 'decode-wrap "bad list")] + [else (hash-ref! ht l + (lambda () + (cons (decode-one (car l) ht) + (decode-map decode-one (cdr l) ht))))])) + +(define (decode-shift s ht) + (hash-ref! ht s + (lambda () + (match s + [(vector to from) + (module-shift to from #f #f)] + [(vector to from i-to i-from) + (module-shift to from i-to i-from)] + [_ (error 'decode-wrap "bad shift")])))) + +(define (decode-scope s ht) + (or + (and (eq? s root-scope) + s) + (hash-ref ht s + (lambda () + (unless (encoded-scope? s) + (error 'decode-wrap "bad scope: ~e" s)) + (define v (encoded-scope-content s)) + (define kind + (match v + [(? number?) v] + [(cons (? number?) _) + (car v)] + [else (error 'decode-wrap "bad scope")])) + (define sc (scope (encoded-scope-relative-id s) + (case kind + [(0 1) 'module] + [(2) 'macro] + [(3) 'local] + [(4) 'intdef] + [else 'use-site]) + null + null + #f)) + (hash-set! ht s sc) + (unless (number? v) + (define-values (bulk-bindings end) + (let loop ([l (cdr v)] [bulk-bindings null]) + (cond + [(pair? l) + (loop (cdr l) (cons (list (decode-scope-set (caar l) ht) + (decode-bulk-import (cdar l) ht)) + bulk-bindings))] + [else (values (reverse bulk-bindings) l)]))) + (set-scope-bulk-bindings! sc bulk-bindings) + (unless (and (vector? end) + (even? (vector-length end))) + (error 'decode-wrap "bad scope")) + (define bindings + (let loop ([i 0]) + (cond + [(= i (vector-length end)) null] + [else + (append (for/list ([p (in-list (vector-ref end (add1 i)))]) + (list (vector-ref end i) + (decode-scope-set (car p) ht) + (decode-binding (cdr p) ht))) + (loop (+ i 2)))]))) + (set-scope-bindings! sc bindings)) + sc)))) + +(define (decode-scope-set l ht) + (decode-map decode-scope l ht)) + +(define (decode-binding b ht) + (hash-ref! ht b + (lambda () + (match b + [(box (cons base-b (cons (cons sym wraps) phase))) + (free-id=?-binding + (decode-binding base-b ht) + (stx-obj sym (decode-wrap wraps ht) #f #hasheq() 'clean) + phase)] + [(? symbol?) + (local-binding b)] + [else + ;; Leave it encoded, so that the compactness (or not) + ;; of the encoding is visible; clients decode further + ;; with `decode-module-binding` + (module-binding b)])))) + +(define (decode-module-binding b name) + (define-values (insp-desc rest-b) + (match b + [(cons (? symbol?) _) + (values (car b) (cdr b))] + [else + (values #f b)])) + (define (decode-nominal-modidx-plus-phase n mod-phase) + (match n + [(? module-path-index?) + (values n mod-phase 0)] + [(cons nom-modix (cons import-phase nom-phase)) + (values nom-modix nom-phase import-phase)] + [(cons nom-modix import-phase) + (values nom-modix mod-phase import-phase)] + [_ + (error 'decode-module-binding "bad encoding")])) + (match rest-b + [(and modidx (? module-path-index?)) + (decoded-module-binding modidx name 0 + modidx name 0 + 0 insp-desc)] + [(cons (and modidx (? module-path-index?)) + (and name (? symbol?))) + (decoded-module-binding modidx name 0 + modidx name 0 + 0 insp-desc)] + [(cons (and modidx (? module-path-index?)) + (and nom-modidx (? module-path-index?))) + (decoded-module-binding modidx name 0 + nom-modidx name 0 + 0 insp-desc)] + [(list* modidx (and name (? symbol?)) + nominal-modidx-plus-phase nom-name) + (define-values (nom-modidx nom-phase import-phase) + (decode-nominal-modidx-plus-phase nominal-modidx-plus-phase 0)) + (decoded-module-binding modidx name 0 + nom-modidx nom-name nom-phase + import-phase insp-desc)] + [(list* modidx mod-phase (and name (? symbol?)) + nominal-modidx-plus-phase nom-name) + (define-values (nom-modidx nom-phase import-phase) + (decode-nominal-modidx-plus-phase nominal-modidx-plus-phase mod-phase)) + (decoded-module-binding modidx name mod-phase + nom-modidx nom-name nom-phase + import-phase insp-desc)] + [_ (error 'decode-module-binding "bad encoding")])) + +(define (decode-bulk-import l ht) + (hash-ref! ht l + (lambda () + (match l + [(vector (and modidx (? module-path-index?)) + src-phase + info + (and insp-desc (or #f (? symbol?)))) + (define-values (phase prefix excepts) + (match info + [(or #f (? exact-integer?)) + (values info #f '#())] + [(cons phase (and prefix (? symbol?))) + (values phase prefix '#())] + [(cons phase (cons excepts prefix)) + (values phase prefix excepts)] + [(cons phase excepts) + (values phase #f excepts)] + [_ (error 'decode-wrap "bad bulk import info")])) + (all-from-module modidx + phase + src-phase + insp-desc + (if excepts + (vector->list excepts) + null) + prefix)] + [_ (error 'decode-wrap "bad bulk import")])))) + +(define (decode-shifted-multi-scope sms ht) + (unless (pair? sms) + (error 'decode-wrap "bad multi-scope pair")) + (list (decode-multi-scope (car sms) ht) + (cdr sms))) + +(define (decode-multi-scope ms ht) + (unless (and (vector? ms) + (odd? (vector-length ms))) + (error 'decode-wrap "bad multi scope")) + (hash-ref ht ms + (lambda () + (define multi (multi-scope (hash-count ht) + (vector-ref ms (sub1 (vector-length ms))) + null)) + (hash-set! ht ms multi) + (define scopes + (let loop ([i 0]) + (cond + [(= (add1 i) (vector-length ms)) null] + [else + (define s (decode-scope (vector-ref ms (add1 i)) ht)) + (when (scope-multi-owner s) + (error 'decode-wrap "bad scope owner: ~e while reading ~e" + (scope-multi-owner s) + multi)) + (set-scope-multi-owner! s multi) + (cons (list (vector-ref ms i) + s) + (loop (+ i 2)))]))) + (set-multi-scope-scopes! multi scopes) + multi))) + +;; ---------------------------------------- + +#; +(begin + (define (compile/write sexp) + (define s (open-output-bytes)) + (write (parameterize ([current-namespace (make-base-namespace)]) + (eval '(require (for-syntax scheme/base))) + (compile sexp)) + s) + (get-output-bytes s)) + + (define (compile/parse sexp) + (let* ([bs (compile/write sexp)] + [p (open-input-bytes bs)]) + (zo-parse p))) + + #;(compile/parse #s(foo 10 13)) + (zo-parse (open-input-file "/home/mflatt/proj/plt/collects/scheme/private/compiled/more-scheme_ss.zo")) + ) diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt new file mode 100644 index 0000000000..a38134be23 --- /dev/null +++ b/zo-lib/compiler/zo-structs.rkt @@ -0,0 +1,236 @@ +#lang racket/base +(require racket/match + racket/contract + racket/list + racket/set) + +#| Unresolved issues + + what are the booleans in lexical-rename? + + contracts that are probably too generous: + prefix-stxs + provided-nom-src + lam-num-params + lexical-rename-alist + all-from-module + +|# + +;; ---------------------------------------- +;; Structures to represent bytecode + +(define-syntax-rule (define-form-struct* id id+par ([field-id field-contract . options] ...)) + (begin + (define-struct id+par ([field-id . options] ...) #:prefab) + (provide + (contract-out + [struct id ([field-id field-contract] ...)])))) + +(define-struct zo () #:prefab) +(provide (struct-out zo)) + +(define-syntax define-form-struct + (syntax-rules () + [(_ (id sup) . rest) + (define-form-struct* id (id sup) . rest)] + [(_ id . rest) + (define-form-struct* id (id zo) . rest)])) + +(define-form-struct function-shape ([arity procedure-arity?] + [preserves-marks? boolean?])) + +(define-form-struct struct-shape ()) +(define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?])) +(define-form-struct (predicate-shape struct-shape) ()) +(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (struct-other-shape struct-shape) ()) + +;; In toplevels of resove prefix: +(define-form-struct global-bucket ([name symbol?])) ; top-level binding +(define-form-struct module-variable ([modidx module-path-index?] + [sym symbol?] + [pos exact-integer?] + [phase exact-nonnegative-integer?] + [constantness (or/c #f 'constant 'fixed + function-shape? + struct-shape?)])) + +(define-form-struct prefix ([num-lifts exact-nonnegative-integer?] + [toplevels (listof (or/c #f symbol? global-bucket? module-variable?))] + [stxs (listof (or/c #f stx?))] ; #f is unusual, but it can happen when one is optimized away at the last moment + [src-inspector-desc symbol?])) + +(define-form-struct form ()) +(define-form-struct (expr form) ()) + +(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] + [binding-namess (hash/c exact-nonnegative-integer? + (hash/c symbol? stx?))] + [prefix prefix?] + [code (or/c form? any/c)])) ; compiled code always wrapped with this + +;; A provided identifier +(define-form-struct provided ([name symbol?] + [src (or/c module-path-index? #f)] + [src-name symbol?] + [nom-src any/c] ; should be (or/c module-path-index? #f) + [src-phase exact-nonnegative-integer?] + [protected? boolean?])) + +(define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] + [pos exact-nonnegative-integer?] + [const? boolean?] + [ready? boolean?])) ; access binding via prefix array (which is on stack) + +(define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin' +(define-form-struct (seq-for-syntax form) ([forms (listof (or/c form? any/c))] ; `begin-for-syntax' + [prefix prefix?] + [max-let-depth exact-nonnegative-integer?] + [dummy (or/c toplevel? #f)])) + +(define-form-struct (inline-variant form) ([direct expr?] + [inline expr?])) + +;; Definitions (top level or within module): +(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] + [rhs (or/c expr? seq? inline-variant? any/c)])) +(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] + [rhs (or/c expr? seq? any/c)] + [prefix prefix?] + [max-let-depth exact-nonnegative-integer?] + [dummy (or/c toplevel? #f)])) + +(define-form-struct (mod form) ([name (or/c symbol? (listof symbol?))] + [srcname symbol?] + [self-modidx module-path-index?] + [prefix prefix?] + [provides (listof (list/c (or/c exact-integer? #f) + (listof provided?) + (listof provided?)))] + [requires (listof (cons/c (or/c exact-integer? #f) + (listof module-path-index?)))] + [body (listof (or/c form? any/c))] + [syntax-bodies (listof (cons/c exact-positive-integer? + (listof (or/c def-syntaxes? seq-for-syntax?))))] + [unexported (listof (list/c exact-nonnegative-integer? + (listof symbol?) + (listof symbol?)))] + [max-let-depth exact-nonnegative-integer?] + [dummy toplevel?] + [lang-info (or/c #f (vector/c module-path? symbol? any/c))] + [internal-context (or/c #f #t stx? (vectorof stx?))] + [binding-names (hash/c exact-integer? + (hash/c symbol? (or/c #t stx?)))] + [flags (listof (or/c 'cross-phase))] + [pre-submodules (listof mod?)] + [post-submodules (listof mod?)])) + +(define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)] + [flags (listof (or/c 'preserves-marks 'is-method 'single-result + 'only-rest-arg-not-used 'sfs-clear-rest-args))] + [num-params exact-nonnegative-integer?] + [param-types (listof (or/c 'val 'ref 'flonum 'fixnum 'extflonum))] + [rest? boolean?] + [closure-map (vectorof exact-nonnegative-integer?)] + [closure-types (listof (or/c 'val/ref 'flonum 'fixnum 'extflonum))] + [toplevel-map (or/c #f (set/c exact-nonnegative-integer?))] + [max-let-depth exact-nonnegative-integer?] + [body (or/c expr? seq? any/c)])) ; `lambda' +(define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over) +(define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? closure?))])) + +(define-form-struct (let-one expr) ([rhs (or/c expr? seq? any/c)] ; pushes one value onto stack + [body (or/c expr? seq? any/c)] + [type (or/c #f 'flonum 'fixnum 'extflonum)] + [unused? boolean?])) +(define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? any/c)])) ; create new stack slots +(define-form-struct (install-value expr) ([count exact-nonnegative-integer?] + [pos exact-nonnegative-integer?] + [boxes? boolean?] + [rhs (or/c expr? seq? any/c)] + [body (or/c expr? seq? any/c)])) ; set existing stack slot(s) +(define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? any/c)])) ; put `letrec'-bound closures into existing stack slots +(define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; box existing stack element + +(define-form-struct (localref expr) ([unbox? boolean?] + [pos exact-nonnegative-integer?] + [clear? boolean?] + [other-clears? boolean?] + [type (or/c #f 'flonum 'fixnum 'extflonum)])) ; access local via stack + + +(define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack) + +(define-form-struct (application expr) ([rator (or/c expr? seq? any/c)] [rands (listof (or/c expr? seq? any/c))])) ; function call +(define-form-struct (branch expr) ([test (or/c expr? seq? any/c)] [then (or/c expr? seq? any/c)] [else (or/c expr? seq? any/c)])) ; `if' +(define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? any/c)] + [val (or/c expr? seq? any/c)] + [body (or/c expr? seq? any/c)])) ; `with-continuation-mark' +(define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? any/c))])) ; `begin0' +(define-form-struct (splice form) ([forms (listof (or/c form? any/c))])) ; top-level `begin' +(define-form-struct (varref expr) ([toplevel (or/c toplevel? #t)] [dummy (or/c toplevel? #f)])) ; `#%variable-reference' +(define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! +(define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) +(define-form-struct (with-immed-mark expr) ([key (or/c expr? seq? any/c)] + [def-val (or/c expr? seq? any/c)] + [body (or/c expr? seq? any/c)])) +(define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive + +;; Top-level `require' +(define-form-struct (req form) ([reqs stx?] [dummy toplevel?])) + + +;; Syntax objects + +(define-form-struct stx ([content stx-obj?])) + +(define-form-struct stx-obj ([datum any/c] ; S-expression with `wrapped` components + [wrap any/c] ; should be `wrap?`, but encoded form appears initially + [srcloc any/c] ; should be `(or/c #f srcloc?)`, but encoded form appears initially + [props (hash/c symbol? any/c)] + [tamper-status (or/c 'clean 'armed 'tainted)])) + +(define-form-struct wrap ([shifts (listof module-shift?)] + [simple-scopes (listof scope?)] + [multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer? (box/c exact-integer?))))])) + +(define-form-struct module-shift ([from (or/c #f module-path-index?)] + [to (or/c #f module-path-index?)] + [from-inspector-desc (or/c #f symbol?)] + [to-inspector-desc (or/c #f symbol?)])) + +(define-form-struct scope ([name (or/c 'root exact-nonnegative-integer?)] ; 'root is special; otherwise, just for printing + [kind symbol?] + [bindings (listof (list/c symbol? (listof scope?) binding?)) #:mutable] + [bulk-bindings (listof (list/c (listof scope?) all-from-module?)) #:mutable] + [multi-owner (or/c #f multi-scope?) #:mutable])) +(define-form-struct multi-scope ([name exact-nonnegative-integer?] + [src-name any/c] ; debugging info, such as module name + [scopes (listof (list/c (or/c #f exact-integer?) scope?)) #:mutable])) + +(define-form-struct binding ()) +(define-form-struct (free-id=?-binding binding) ([base (and/c binding? + (not/c free-id=?-binding?))] + [id stx-obj?] + [phase (or/c #f exact-integer?)])) +(define-form-struct (local-binding binding) ([name symbol?])) +(define-form-struct (module-binding binding) ([encoded any/c])) +;; Convert `module-binding` to `decoded-module-binding` with `decode-module-binding`: +(define-form-struct (decoded-module-binding binding) ([path (or/c #f module-path-index?)] + [name symbol?] + [phase exact-integer?] + [nominal-path (or/c #f module-path-index?)] + [nominal-export-name symbol?] + [nominal-phase (or/c #f exact-integer?)] + [import-phase (or/c #f exact-integer?)] + [inspector-desc (or/c #f symbol?)])) + +(define-form-struct all-from-module ([path module-path-index?] + [phase (or/c exact-integer? #f)] + [src-phase (or/c exact-integer? #f)] + [inspector-desc symbol?] + [exceptions (listof symbol?)] + [prefix (or/c symbol? #f)])) diff --git a/zo-lib/info.rkt b/zo-lib/info.rkt new file mode 100644 index 0000000000..b6e36644e7 --- /dev/null +++ b/zo-lib/info.rkt @@ -0,0 +1,11 @@ +#lang info + +(define collection 'multi) + +(define deps '("base")) + +(define pkg-desc "Libraries for handling zo files") + +(define pkg-authors '(mflatt)) + +(define version "1.2")