1#lang racket/base
2(require racket/list
3         racket/port
4         "match.rkt"
5         "out.rkt"
6         "prune.rkt"
7         "unique.rkt"
8         "sort.rkt"
9         "id.rkt"
10         "vehicle.rkt"
11         "top-name.rkt"
12         "prim-name.rkt"
13         "ref.rkt"
14         "function.rkt"
15         "state.rkt"
16         "generate.rkt"
17         "lambda.rkt"
18         "struct.rkt"
19         "union.rkt"
20         "debug.rkt")
21
22(provide (rename-out [main-cify cify])
23         re-unique)
24
25(define (main-cify out-file exports in-e prim-knowns
26                   #:debug? [debug? #f]
27                   #:preamble [preamble '()]
28                   #:postamble [postamble '()])
29  (current-debug debug?)
30  (call-with-output-file*
31   out-file
32   #:exists 'truncate/replace
33   (lambda (out)
34     (parameterize ([current-c-output-port out])
35       (for-each out-exact preamble)
36       (to-c exports in-e prim-knowns)
37       (for-each out-exact postamble)))))
38
39;; ----------------------------------------
40
41(define (to-c exports in-e prim-knowns)
42  (generate-header)
43
44  ;; Inlining may have made some definitions useless:
45  (define pruned-e (prune-unused in-e exports))
46
47  ;; Make sure all names are unique:
48  (define unique-e (re-unique pruned-e))
49
50  ;; Find all `define`d names and `let[rec[*]]` names that are
51  ;; flattend into the top sequence:
52  (define top-names (extract-top-names #hasheq() unique-e))
53
54  ;; Find all the primitives that we'll need to call:
55  (define prim-names (extract-prim-names unique-e top-names))
56
57  ;; Find mutable variables, which will need to be boxed:
58  (define state (make-state))
59  (extract-state! state unique-e)
60
61  ;; Wrap `ref` around every local-variable reference. Also,
62  ;; perform copy propagation:
63  (define e (wrap-ref unique-e top-names prim-names state))
64
65  ;; Find all `lambda`s and `case-lambda`s, mapping each to
66  ;; a newly synthesized name:
67  (define lambdas (make-hasheq))
68  (extract-lambdas! lambdas e)
69
70  (define struct-knowns (extract-structs e))
71
72  ;; Find all functions that do not need to be kept in a closure.
73  ;; Top-level functions and functions bound with `letrec` are in this
74  ;; category:
75  (define functions (extract-functions #hasheq() e lambdas))
76  (for ([(id f) (in-sorted-hash functions symbol<?)])
77    (define e (function-e f))
78    (hash-set! lambdas e (make-lam id e)))
79
80  (define knowns (hash-directed-union struct-knowns functions))
81
82  ;; Generate top-level sequence just to set free-variable lists and
83  ;; other state for each lambda:
84  (define max-top-runstack-depth
85    (parameterize ([current-c-output-port (open-output-nowhere)])
86      (define vehicles (for/list ([lam (in-sorted-hash-values lambdas (compare symbol<? lam-id))])
87                         (lam-vehicle lam)))
88      (define max-top-runstack-depth
89        (generate-tops e 0 exports knowns top-names state lambdas prim-names prim-knowns))
90      (generate-vehicles vehicles lambdas knowns top-names state prim-names prim-knowns)
91      (hash-set! state '#:done? #t)
92      (reset-genid-counters! '(c_args))
93      max-top-runstack-depth))
94
95  ;; Now we know if a function that isn't already in `functions`
96  ;; has zero free variables. If so, effectively lift it to
97  ;; allocate the closure once
98  (define closed-anonymous-functions
99    (for/hash ([lam (in-hash-values lambdas)]
100               #:when (and (null? (lam-free-var-refs lam))
101                           ;; No need if it's only formed at the top, unless
102                           ;; `c_self` isn't available for overflow handling:
103                           (or (lam-under-lambda? lam)
104                               (not (vehicle-closure? (lam-vehicle lam))))
105                           (not (hash-ref functions (lam-id lam) #f))
106                           (not (lam-unused? lam))))
107      (set-lam-moved-to-top?! lam #t)
108      (values (lam-id lam) lam)))
109
110  ;; Generate prim record:
111  (generate-struct "c_prims" prim-names)
112  (out "static struct c_prims_t c_prims;")
113
114  ;; Generate top-variable record:
115  (generate-struct "startup_instance_top" (hash-union (hash-union top-names functions)
116                                                      closed-anonymous-functions))
117  (out "THREAD_LOCAL_DECL(static struct startup_instance_top_t *c_startup_instance_top);")
118  (out "#define c_top c__startup_instance_top")
119
120  (define vehicles (merge-vehicles! lambdas state))
121
122  ;; Generate all the lambda bodies:
123  (generate-prototypes vehicles)
124  (generate-vehicles vehicles lambdas knowns top-names state prim-names prim-knowns)
125
126  ;; Generate top-level sequence, this time to output:
127  (hash-set! state '#:tops? #t)
128  (generate-tops e max-top-runstack-depth exports knowns top-names state lambdas prim-names prim-knowns)
129
130  (generate-footer))
131