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