1(module compile-startup '#%kernel
2  (#%require '#%linklet
3             "help-startup.rkt")
4
5  ;; Decode a linklet S-expression from "startup.inc" (in the source
6  ;; directory), compile it, and write it back as "cstartup.inc" (in
7  ;; the build directory)
8
9  (define-values (dest) (vector-ref (current-command-line-arguments) 0))
10  (define-values (zo-dest) (vector-ref (current-command-line-arguments) 1))
11  (define-values (src) (vector-ref (current-command-line-arguments) 2))
12  (define-values (vers) (vector-ref (current-command-line-arguments) 3))
13  (define-values (other-files) (list-tail (vector->list (current-command-line-arguments)) 4))
14
15  (define-values (version-comparisons) (get-version-comparisons vers))
16
17  ;; Bail out if we don't need to do anything:
18  (if (file-exists? dest)
19      (if (call-with-input-file dest (lambda (i)
20                                       (begin
21                                         (read-line i 'any)
22                                         (not (eof-object? (read-line i 'any))))))
23          (if (andmap (lambda (f)
24                        ((file-or-directory-modify-seconds dest)
25                         . > .
26                         (file-or-directory-modify-seconds f)))
27                      (list* src vers other-files))
28              (exit 0)
29              (void))
30          (void))
31      (void))
32
33  ;; Startup code as an S-expression uses the pattern
34  ;;   (lambda <formals> (begin '<id> <expr>))
35  ;; or
36  ;;   (case-lambda [<formals> (begin '<id> <expr>)] <clause> ...)
37  ;; to record a name for a function. Detect that pattern and
38  ;; shift to an 'inferred-name property. We rely on the fact
39  ;; that the names `lambda`, `case-lambda`, and `quote` are
40  ;; never shadowed, so we don't have to parse expression forms
41  ;; in general.
42  (define-values (rename-functions)
43    (lambda (e)
44      (if (if (pair? e)
45              (eq? 'quote (car e))
46              #f)
47          e
48          (let-values ([(name)
49                        (if (pair? e)
50                            (let-values ([(begin-name)
51                                          (lambda (b)
52                                            (if (pair? b)
53                                                (if (eq? 'begin (car b))
54                                                    (if (pair? (cdr b))
55                                                        (if (pair? (cddr b))
56                                                            (let-values ([(a) (cadr b)])
57                                                              (if (pair? a)
58                                                                  (if (eq? 'quote (car a))
59                                                                      (cadr a)
60                                                                      #f)
61                                                                  #f))
62                                                            #f)
63                                                        #f)
64                                                    #f)
65                                                #f))])
66                              (if (eq? 'lambda (car e))
67                                  (let-values ([(b) (caddr e)])
68                                    (begin-name b))
69                                  (if (eq? 'case-lambda (car e))
70                                      (if (pair? (cdr e))
71                                          (let-values ([(clause) (cadr e)])
72                                            (begin-name (cadr clause)))
73                                          #f)
74                                      #f)))
75                            #f)])
76            (if name
77                (correlated-property (datum->correlated #f (cons (car e) (rename-functions (cdr e))))
78                                     'inferred-name
79                                     name)
80                (if (pair? e)
81                    (cons (rename-functions (car e))
82                          (rename-functions (cdr e)))
83                    e))))))
84  (define-values (datum->correlated) (hash-ref (primitive-table '#%kernel) 'datum->syntax))
85  (define-values (correlated-property) (hash-ref (primitive-table '#%kernel) 'syntax-property))
86
87  (define-values (linklet) (compile-linklet (rename-functions (get-linklet src))
88                                            #f #f #f
89                                            '(serializable unsafe static)))
90
91  (define-values (DIGS-PER-LINE) 20)
92
93  ;; In case someone wants to inspect the output with `raco decompile`:
94  (call-with-output-file
95   zo-dest
96   (lambda (outfile) (write (hash->linklet-bundle (hasheq 'startup linklet)) outfile))
97   'truncate)
98
99  (call-with-output-file
100   dest
101   (lambda (outfile)
102     (let-values ([(p) (open-output-bytes)])
103       (write-linklet-bundle-hash (hasheq 'startup linklet) p)
104       (let-values ([(s) (get-output-bytes p)])
105         (fprintf outfile "#if 0 ~a\n" version-comparisons)
106         (fprintf outfile "# include \"startup.inc\"\n")
107         (fprintf outfile "#else\n")
108         (fprintf outfile "static unsigned char expr[] = {\n")
109         (letrec-values ([(loop)
110                          (lambda (chars pos)
111                            (if (null? chars)
112                                (void)
113                                (begin
114                                  (fprintf outfile "~a," (car chars))
115                                  (loop (cdr chars)
116                                        (if (= pos DIGS-PER-LINE)
117                                            (begin
118                                              (newline outfile)
119                                              0)
120                                            (add1 pos))))))])
121                        (loop (bytes->list s) 0))
122         (fprintf outfile "0};\n")
123         (fprintf outfile "# define EVAL_STARTUP EVAL_ONE_SIZED_STR((char *)expr, ~a)\n" (bytes-length s))
124         (fprintf outfile "#endif\n"))))
125   'truncate))
126