1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
#lang racket/base
(require compiler/depend
;; This dependency on `compiler/private/cm-minimal`
;; ensure that it's compiled so that the next use
;; of "setup-go.rkt" doesn't have to start from source
compiler/private/cm-minimal)
;; This module is loaded via `setup/main` with a `--boot` argument
;; that selects this module and sets the compile-file root directory
;; to be within the build directory.
;;
;; Overall arguments:
;;
;; --boot <this-file> <compiled-dir>
;; <target-file> <dep-file/tag> <mod-file>
;; <arg> ...
;;
;; where <mod-file> is the file to load (bootstrapping as needed), and
;; the <arg>s are made the command-line argument for <mod-file>. The
;; <target-file> is the output file that <mod-file> generates. The
;; <dep-file/tag> is written as makefile rule for <target-file>, where
;; a "$" is added to the front of <target-file> if it's parenthesized.
;;
;; If <target-file> is `--tag`, then <dep-file/tag> specifies a tag to
;; get stripped form <arg>, there the target file is immediately after
;; the tag. In that case, the dependency file name is formed by using
;; just the target, replacing the suffix with ".d".
;;
;; The point of going through `setup/main` is that the Racket module
;; gets compiled as needed, so that it doesn't have to be loaded from
;; source every time. At the same time `setup/main` detects when files
;; need to be recompiled, either because the underlying Racket's
;; version changed or because a dependency changed.
(provide go)
(define (go orig-compile-file-paths)
(define SETUP-ARGS 6)
(define prog-args (list-tail (vector->list (current-command-line-arguments)) SETUP-ARGS))
(define target-file-spec (vector-ref (current-command-line-arguments) 3))
(define target-tag (and (equal? target-file-spec "--tag")
(vector-ref (current-command-line-arguments) 4)))
(define target-file (if target-tag
(let loop ([l prog-args])
(cond
[(or (null? l) (null? (cdr l)))
(error 'setup-go "could not find target")]
[(equal? (car l) target-tag) (cadr l)]
[else (loop (cdr l))]))
target-file-spec))
(define make-dep-file (if target-tag
(path-replace-suffix target-file #".d")
(vector-ref (current-command-line-arguments) 4)))
(define mod-file (simplify-path (path->complete-path (vector-ref (current-command-line-arguments) 5))))
(parameterize ([current-command-line-arguments
;; Discard `--boot` through arguments to this
;; module, and also strip `target-tag` (if any).
(list->vector (let loop ([l prog-args])
(cond
[(null? l) '()]
[(equal? (car l) target-tag) (cdr l)]
[else (cons (car l) (loop (cdr l)))])))])
;; In case multiple xforms run in parallel, use a lock file so
;; that only one is building.
(define lock-file (build-path (car (current-compiled-file-roots)) "SETUP-LOCK"))
(define lock-port (open-output-file #:exists 'truncate/replace lock-file))
(let loop ([n 0])
(when (= n 3)
(printf "Waiting on lock: ~a\n" lock-file))
(unless (port-try-file-lock? lock-port 'exclusive)
(sleep 0.1)
(loop (add1 n))))
(with-handlers ([exn? (lambda (exn)
;; On any exception, try to delete the target file
(with-handlers ([exn:fail:filesystem?
(lambda (exn) (log-error "~s" exn))])
(when (file-exists? target-file)
(delete-file target-file)))
(raise exn))])
(dynamic-wind
void
(lambda ()
;; Load the requested module, but don't instantiate:
(dynamic-require mod-file (void)))
(lambda ()
(port-file-unlock lock-port)))
;; Record dependencies (before running `mod-file`, in case
;; it mangles parameters)
(define deps (cons mod-file
(module-recorded-dependencies mod-file)))
(define (quote-if-space s)
;; We're not handling arbitrary paths, but at least support spaces
(if (regexp-match? #rx" " s) (format "\"~a\"" s) s))
(call-with-output-file make-dep-file
#:exists 'truncate
(lambda (o)
(fprintf o "~a: " (if (regexp-match? #rx"^[(].*[)]$" target-file)
(string-append "$" target-file)
(quote-if-space target-file)))
(for ([dep (in-list deps)])
(fprintf o " \\\n ~a" (quote-if-space dep)))
(newline o)
(for ([dep (in-list deps)])
(fprintf o "\n~a:\n" (quote-if-space dep)))))
;; Now that the lock is released, instantiate:
(let ([main `(submod ,mod-file main)])
(if (module-declared? main #t)
(dynamic-require main #f)
(dynamic-require mod-file #f))))))
|
