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