1#lang racket/base 2(require racket/set 3 compiler/cm 4 racket/file 5 "find.rkt" 6 "name.rkt" 7 "merge.rkt" 8 "gc.rkt" 9 "bundle.rkt" 10 "write.rkt") 11 12(provide demodularize 13 14 garbage-collect-toplevels-enabled 15 current-excluded-modules 16 recompile-enabled 17 current-work-directory) 18 19(define garbage-collect-toplevels-enabled (make-parameter #f)) 20(define recompile-enabled (make-parameter 'auto)) 21(define current-work-directory (make-parameter #f)) 22 23(define logger (make-logger 'demodularizer (current-logger))) 24 25(define (demodularize input-file [given-output-file #f]) 26 (define given-work-directory (current-work-directory)) 27 (define work-directory (and (or (not (recompile-enabled)) 28 (not (eq? 'racket (system-type 'vm)))) 29 (or given-work-directory 30 (make-temporary-file "demod-work-~a" 'directory)))) 31 32 (parameterize ([current-logger logger] 33 [current-excluded-modules (for/set ([path (in-set (current-excluded-modules))]) 34 (normal-case-path (simplify-path (path->complete-path path))))]) 35 36 (cond 37 [work-directory 38 (log-info "Compiling modules to ~s" work-directory) 39 (parameterize ([current-namespace (make-empty-namespace)] 40 [current-compiled-file-roots (list (build-path work-directory "native") 41 (build-path work-directory "linklet"))] 42 [current-compile-target-machine #f] 43 [current-multi-compile-any #t]) 44 (namespace-attach-module (variable-reference->namespace (#%variable-reference)) ''#%builtin) 45 (managed-compile-zo input-file))] 46 [else 47 (log-info "Compiling module") 48 (parameterize ([current-namespace (make-base-empty-namespace)]) 49 (managed-compile-zo input-file))]) 50 51 (log-info "Finding modules") 52 (define-values (runs excluded-module-mpis) 53 (parameterize ([current-compiled-file-roots (if work-directory 54 (list (build-path work-directory "linklet")) 55 (current-compiled-file-roots))]) 56 (find-modules input-file))) 57 58 (when (and work-directory (not given-work-directory)) 59 (delete-directory/files work-directory)) 60 61 (log-info "Selecting names") 62 (define-values (names internals lifts imports) (select-names runs)) 63 64 (log-info "Merging linklets") 65 (define-values (body first-internal-pos merged-internals linkl-mode get-merge-info) 66 (merge-linklets runs names internals lifts imports)) 67 68 (log-info "GCing definitions") 69 (define-values (new-body new-internals new-lifts) 70 (gc-definitions linkl-mode body internals lifts first-internal-pos merged-internals 71 #:assume-pure? (garbage-collect-toplevels-enabled))) 72 73 (log-info "Bundling linklet") 74 (define bundle (wrap-bundle linkl-mode new-body new-internals new-lifts 75 excluded-module-mpis 76 get-merge-info 77 (let-values ([(base name dir?) (split-path input-file)]) 78 (string->symbol (path->string name))))) 79 80 (log-info "Writing bytecode") 81 (define output-file (or given-output-file 82 (path-add-suffix input-file #"_merged.zo"))) 83 (write-module output-file bundle) 84 85 (when (or (eq? (recompile-enabled) #t) 86 (and (eq? (recompile-enabled) 'auto) 87 (eq? linkl-mode 's-exp))) 88 (log-info "Recompiling and rewriting bytecode") 89 (define zo (compiled-expression-recompile 90 (parameterize ([read-accept-compiled #t]) 91 (call-with-input-file* output-file read)))) 92 (call-with-output-file* output-file 93 #:exists 'replace 94 (lambda (out) (write zo out)))))) 95