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