1#lang racket/base 2(require (only-in '#%linklet 3 primitive-table 4 primitive-in-category?) 5 racket/cmdline 6 "../../schemify/schemify.rkt" 7 "../../cify/literal.rkt" 8 "../../schemify/known.rkt" 9 "../../schemify/lift.rkt" 10 "../../schemify/reinfer-name.rkt" 11 "../../schemify/wrap.rkt" 12 "../../schemify/match.rkt" 13 "../../cify/main.rkt" 14 "help-startup.rkt") 15 16(define dest "cstartup.inc") 17(define version-line (format "/* version: ~a */" (version))) 18 19(define debug? #f) 20 21(define-values (src vers deps) 22 (command-line 23 #:args (src-file vers-file . dep) 24 (values src-file vers-file dep))) 25 26(define content (get-linklet src)) 27(define version-comparisons (get-version-comparisons vers)) 28 29(define l (cdddr content)) 30 31(define (arity->mask a) 32 (cond 33 [(exact-nonnegative-integer? a) 34 (arithmetic-shift 1 a)] 35 [(arity-at-least? a) 36 (bitwise-xor -1 (sub1 (arithmetic-shift 1 (arity-at-least-value a))))] 37 [(list? a) 38 (let loop ([mask 0] [l a]) 39 (cond 40 [(null? l) mask] 41 [else 42 (let ([a (car l)]) 43 (cond 44 [(or (exact-nonnegative-integer? a) 45 (arity-at-least? a)) 46 (loop (bitwise-ior mask (arity->mask a)) (cdr l))] 47 [else #f]))]))] 48 [else #f])) 49 50(define prim-knowns 51 (for*/hash ([table-name '(#%linklet #%kernel 52 #%paramz #%unsafe #%foreign 53 #%futures #%place 54 #%flfxnum #%extfl #%network)] 55 [(name v) (in-hash (primitive-table table-name))]) 56 (values name 57 (cond 58 [(procedure? v) 59 (define arity-mask (arity->mask (procedure-arity v))) 60 (cond 61 [(primitive-in-category? name 'omitable) 62 (known-procedure/succeeds arity-mask)] 63 [else 64 (known-procedure arity-mask)])] 65 [else 66 a-known-constant])))) 67 68(printf "Serializable...\n") 69(define-values (bodys/literals-extracted literals) 70 (time (extract-literals l))) 71 72;; Startup code reuses names to keep it compact; make 73;; te names unique again 74(define bodys/re-uniqued 75 (cdr (re-unique `(begin . ,bodys/literals-extracted)))) 76 77(printf "Schemify...\n") 78(define body 79 (time 80 (schemify-body (recognize-inferred-names bodys/re-uniqued) prim-knowns #hasheq() #hasheq() #hasheq() 81 'cify 82 ;; unsafe mode: 83 #t 84 ;; no prompts: 85 #t 86 ;; no explicit unnamed: 87 #f))) 88 89(printf "Lift...\n") 90(define lifted-body 91 (time 92 (lift-in-schemified-body body))) 93 94(define converted-body 95 (append (for/list ([p (in-list literals)]) 96 (cons 'define p)) 97 lifted-body)) 98 99;; Convert 'inferred-name properties back to `(lambda <formals> (begin 'name <expr>))` form 100(define (restore-inferred-names e) 101 (cond 102 [(wrap? e) 103 (cond 104 [(wrap-property e 'inferred-name) 105 => (lambda (name) 106 (match e 107 [`(lambda ,formals ,expr) 108 `(lambda ,formals (begin ',name ,(restore-inferred-names expr)))] 109 [`(case-lambda [,formals ,expr] . ,rest) 110 `(case-lambda [,formals (begin ',name ,(restore-inferred-names expr))] 111 . ,(restore-inferred-names rest))] 112 [`,_ 113 (restore-inferred-names (unwrap e))]))] 114 [else 115 (restore-inferred-names (unwrap e))])] 116 [(not (pair? e)) e] 117 [else (cons (restore-inferred-names (car e)) 118 (restore-inferred-names (cdr e)))])) 119 120(cify dest (caddr content) `(begin . ,(restore-inferred-names converted-body)) prim-knowns 121 #:debug? debug? 122 #:preamble (append (list version-line 123 (format "#if 0 ~a" version-comparisons) 124 "#include \"startup.inc\"" 125 "#else") 126 (if debug? 127 (list "# define c_VALIDATE_DEBUG") 128 (list)) 129 (list "# include \"startup-glue.inc\"")) 130 #:postamble (list (format "#endif"))) 131