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