1#lang racket/base
2(require "arg.rkt"
3         "sort.rkt"
4         "id.rkt"
5         "union-find.rkt")
6
7(provide (struct-out lam)
8         (struct-out vehicle)
9         make-lam
10         top-ref
11         lam-calls-non-immediate!
12         lam-called-direct!
13         lam-add-transitive-tail-apply!
14         merge-vehicles!)
15
16(struct lam (id e
17                [free-var-refs #:mutable]
18                [env #:mutable]
19                loop-targets
20                [max-jump-argc #:mutable]
21                [need-entry? #:mutable]
22                [vehicle #:mutable]
23                [index #:mutable]
24                [under-lambda? #:mutable] ; inside another function?
25                [moved-to-top? #:mutable]
26                [unused? #:mutable]       ; in case a `lambda` gets dropped completely
27                [can-tail-apply? #:mutable]   ; if any in vehicle can tail apply
28                [transitive-tail-applies #:mutable] ; table used for fixpoint calculation of `can-tail-apply?`
29                [can-leaf? #:mutable]))   ; never syncs runstack => GC-independent leaf
30
31(struct vehicle ([id #:mutable]
32                 [lams #:mutable]
33                 [closure? #:mutable]
34                 [uses-top? #:mutable]
35                 [min-argc #:mutable]
36                 [max-jump-argc #:mutable]
37                 [max-runstack-depth #:mutable]
38                 [called-direct? #:mutable] ; if the vehicle can be called directly
39                 [calls-non-immediate? #:mutable]))
40
41(define (make-lam id e)
42  (define-values (min-argc max-argc) (lambda-arity e))
43  (define a-vehicle (vehicle id '() #f #f min-argc 0 0 #f #f))
44  (define a-lam (lam id e #f #f (make-hasheqv) 0 #f a-vehicle 0 #f #f #f #f #hasheq() #f))
45  (set-vehicle-lams! a-vehicle (list a-lam))
46  a-lam)
47
48(define (top-ref in-lam id)
49  (when in-lam
50    (set-vehicle-uses-top?! (lam-vehicle in-lam) #t))
51  (format "c_top->~a" (cify id)))
52
53(define (lam-calls-non-immediate! in-lam)
54  (when in-lam
55    (set-vehicle-calls-non-immediate?! (lam-vehicle in-lam) #t)))
56
57(define (lam-called-direct! in-lam)
58  (when in-lam
59    (set-vehicle-called-direct?! (lam-vehicle in-lam) #t)))
60
61(define (lam-add-transitive-tail-apply! lam target-lam)
62  (set-lam-transitive-tail-applies!
63   lam
64   (hash-set (lam-transitive-tail-applies lam) target-lam #t)))
65
66(define (merge-vehicles! lambdas state)
67  (define vehicles
68    (for/fold ([vehicles #hash()]) ([lam (in-sorted-hash-values lambdas (compare symbol<? lam-id))]
69                                    #:unless (lam-unused? lam))
70      (define vehicle-lam (find! state lam))
71      (define vehicle (lam-vehicle vehicle-lam))
72      (define old-vehicle (lam-vehicle lam))
73      (set-vehicle-max-jump-argc! vehicle (max (vehicle-max-jump-argc vehicle)
74                                               (lam-max-jump-argc lam)))
75      (unless (null? (lam-free-var-refs lam))
76        (set-vehicle-closure?! vehicle #t))
77      (unless (eq? vehicle old-vehicle)
78        (define lams (vehicle-lams vehicle))
79        (when (null? (cdr lams))
80          (set-vehicle-id! vehicle (genid 'c_vehicle)))
81        (set-lam-index! lam (length lams))
82        (set-vehicle-lams! vehicle (cons lam lams))
83        (set-vehicle-uses-top?! vehicle (or (vehicle-uses-top? vehicle)
84                                            (vehicle-uses-top? old-vehicle)))
85        (set-vehicle-min-argc! vehicle (min (vehicle-min-argc vehicle)
86                                            (vehicle-min-argc old-vehicle)))
87        (set-vehicle-max-runstack-depth! vehicle (max (vehicle-max-runstack-depth vehicle)
88                                                      (vehicle-max-runstack-depth old-vehicle)))
89        (set-vehicle-called-direct?! vehicle (or (vehicle-called-direct? vehicle)
90                                                 (vehicle-called-direct? old-vehicle)))
91        (set-vehicle-calls-non-immediate?! vehicle (or (vehicle-calls-non-immediate? vehicle)
92                                                       (vehicle-calls-non-immediate? old-vehicle)))
93        (set-lam-vehicle! lam vehicle)
94        (set-vehicle-closure?! vehicle #t))
95      (hash-set vehicles vehicle (add1 (hash-ref vehicles vehicle 0)))))
96  (printf "vehicles: ~a\n" (hash-count vehicles))
97  (printf "max vehicle size ~a\n" (for/fold ([n 0]) ([m (in-hash-values vehicles)])
98                                    (max n m)))
99  ;; Fixpoint to determine tail-call behavior:
100  (let loop ()
101    (when (for*/fold ([changed? #f]) ([vehicle (in-hash-keys vehicles)]
102                                      [lam (in-list (vehicle-lams vehicle))])
103            (or (and (not (lam-can-tail-apply? lam))
104                     (for/or ([other-lam (in-hash-keys (lam-transitive-tail-applies lam))])
105                       (and (lam-can-tail-apply? other-lam)
106                            (begin
107                              (set-lam-can-tail-apply?! lam #t)
108                              #t))))
109                changed?))
110      (loop)))
111  ;; Reverse accumulated lams:
112  (for/list ([vehicle (in-sorted-hash-keys vehicles (compare symbol<? vehicle-id))])
113    (set-vehicle-lams! vehicle (reverse (vehicle-lams vehicle)))
114    vehicle))
115