1#lang racket/base 2(require "out.rkt" 3 "id.rkt" 4 "ref.rkt" 5 "state.rkt" 6 "union.rkt" 7 "sort.rkt" 8 "debug.rkt") 9 10(provide make-runstack 11 runstack-push! 12 runstack-pop! 13 runstack-ref 14 runstack-ref-use! 15 runstack-assign 16 make-runstack-assign 17 runstack-stack-ref 18 runstack-ref-pos 19 runstack-sync! 20 runstack-synced! 21 runstack-max-depth 22 runstack-ever-synced? 23 24 runstack-branch-before! 25 runstack-branch-other! 26 runstack-branch-merge! 27 runstack-branch-refs 28 runstack-stage-clear-unused! 29 runstack-stage-clear!) 30 31(struct runstack (rs-state ; shared state table 32 depth ; current stack depth 33 max-depth ; max reached stack depth 34 sync-depth ; depth that MZ_RUNSTACK currently has, `#f` if unknown 35 vars ; list of pushed vars, newest first 36 var-depths ; pushed var -> 'local or distance from stack start 37 need-inits ; set of pushed vars that are not yet initialized 38 unsynced ; pushed vars that haven't yet lived through a GC boundary 39 unsynced-refs ; per-var refs that haven't yet lived through a GC boundary 40 all-refs ; per-var, all references encountered 41 staged-clears ; clears staged by branching 42 ever-synced?) ; whether the runstack is ever synced 43 #:mutable) 44 45(define (make-runstack state) 46 (define rs-state (or (hash-ref state '#:runstack #f) 47 (let ([ht (make-hasheq)]) 48 (hash-set! state '#:runstack ht) 49 ht))) 50 (runstack rs-state 51 0 ; depth 52 0 ; max-depth 53 #f ; sync-depth 54 '() ; vars 55 (make-hasheq) ; var-depths 56 (make-hasheq) ; need-inits 57 (make-hasheq) ; unsyned 58 (make-hasheq) ; unsynced-refs 59 #hasheq() ; all-refs 60 #hasheq() ; staged-clears 61 #f)) ; ever-synced? 62 63(define (runstack-push! rs id 64 #:referenced? [referenced? #t] 65 #:local? [local? #f] 66 #:track-local? [track-local? #f]) 67 (set-runstack-vars! rs (cons id (runstack-vars rs))) 68 (cond 69 [(or local? 70 (and track-local? 71 referenced? 72 (eq? 'local (hash-ref (runstack-rs-state rs) id #f)))) 73 ;; A previous pass determined that this variable will not 74 ;; live across a GC boundary, so it can be stored in a C local. 75 ;; Note that we're sharing a global table, even though an id 76 ;; can have different extents due to closures; but only `let` 77 ;; bindings are "tracked", and each of those is unique. 78 (hash-set! (runstack-var-depths rs) id 'local) 79 (out "Scheme_Object *~a;" (cify id))] 80 [else 81 (define depth (add1 (runstack-depth rs))) 82 (set-runstack-depth! rs depth) 83 (set-runstack-max-depth! rs (max depth (runstack-max-depth rs))) 84 (hash-set! (runstack-var-depths rs) id depth) 85 (hash-set! (runstack-need-inits rs) id #t) 86 (hash-set! (runstack-unsynced rs) id #t) 87 (out "~aconst int ~a = -~a;~a" 88 (if referenced? "" "/* ") 89 (cify id) depth 90 (if referenced? "" " */"))])) 91 92(define (runstack-pop! rs [n 1] 93 #:track-local? [track-local? #f]) 94 (define var-depths (runstack-var-depths rs)) 95 (let loop ([n n]) 96 (unless (zero? n) 97 (define var (car (runstack-vars rs))) 98 (unless (eq? 'local (hash-ref var-depths var #f)) 99 (set-runstack-depth! rs (- (runstack-depth rs) 1)) 100 (hash-remove! (runstack-need-inits rs) var) 101 (when (hash-ref (runstack-unsynced rs) var #f) 102 (hash-remove! (runstack-unsynced rs) var)) 103 (when (and track-local? 104 ;; If all references were pre-sync, it can be local 105 (for/and ([state (in-hash-values (hash-ref (runstack-all-refs rs) var '#hasheq()))]) 106 (eq? state 'pre-sync))) 107 (hash-set! (runstack-rs-state rs) var 'local)) 108 (let ([refs (hash-ref (runstack-unsynced-refs rs) var '())]) 109 (hash-remove! (runstack-unsynced-refs rs) var) 110 (for ([ref (in-list refs)]) 111 (set-ref-last-use?! ref #f)))) 112 (set-runstack-vars! rs (cdr (runstack-vars rs))) 113 (set-runstack-all-refs! rs (hash-remove (runstack-all-refs rs) var)) 114 (hash-remove! var-depths var) 115 (set-runstack-staged-clears! rs (hash-remove (runstack-staged-clears rs) var)) 116 (loop (sub1 n))))) 117 118(define (runstack-ref rs id #:assign? [assign? #f] #:ref [ref #f] #:values-ok? [values-ok? #f]) 119 (when ref 120 (runstack-ref-use! rs ref) 121 ;; Remember the ref, so we can clear its `last-use?` if no sync 122 ;; happens before the variable is popped 123 (hash-set! (runstack-unsynced-refs rs) id 124 (cons ref (hash-ref (runstack-unsynced-refs rs) id '())))) 125 (define s 126 (cond 127 [(eq? 'local (hash-ref (runstack-var-depths rs) id #f)) 128 (format "~a" (cify id))] 129 [(and ref (ref-last-use? ref)) 130 (format "c_last_use(c_runbase, ~a)" (cify id))] 131 [else 132 (format "c_runbase[~a]" (cify id))])) 133 (if (and (current-debug) (not values-ok?) (not assign?)) 134 (format "c_validate(~a)" s) 135 s)) 136 137(define (runstack-ref-use! rs ref) 138 (set-runstack-all-refs! rs (hash-set2 (runstack-all-refs rs) (ref-id ref) ref 139 (if (hash-ref (runstack-unsynced rs) (ref-id ref) #f) 140 'pre-sync 141 'post-sync)))) 142 143(define (runstack-assign rs id) 144 (hash-remove! (runstack-need-inits rs) id) 145 (runstack-ref rs id #:assign? #t)) 146 147(define (make-runstack-assign rs id) 148 (lambda (s) (out "~a = ~a;" (runstack-assign rs id) s))) 149 150(define (runstack-stack-ref rs) 151 (format "(c_runbase-~a)" (runstack-depth rs))) 152 153(define (runstack-ref-pos rs id) 154 (hash-ref (runstack-var-depths rs) id #f)) 155 156(define (runstack-sync! rs) 157 (set-runstack-ever-synced?! rs #t) 158 (hash-clear! (runstack-unsynced rs)) 159 (hash-clear! (runstack-unsynced-refs rs)) 160 (runstack-generate-staged-clears! rs) 161 (define vars (sort (hash-keys (runstack-need-inits rs)) symbol<?)) 162 (for ([var (in-list vars)]) 163 (out "~a = c_RUNSTACK_INIT_VAL;" (runstack-assign rs var))) 164 (unless (eqv? (runstack-depth rs) (runstack-sync-depth rs)) 165 (out "c_current_runstack = ~a;" (runstack-stack-ref rs)) 166 (set-runstack-sync-depth! rs (runstack-depth rs)))) 167 168(define (runstack-synced! rs) 169 (hash-clear! (runstack-need-inits rs)) 170 (hash-clear! (runstack-unsynced rs)) 171 (hash-clear! (runstack-unsynced-refs rs))) 172 173(struct runstack-branch-state (need-inits sync-depth unsynced-refs all-refs staged-clears)) 174 175(define (runstack-branch-before! rs) 176 (define unsynced-refs (runstack-unsynced-refs rs)) 177 (define all-refs (runstack-all-refs rs)) 178 (set-runstack-unsynced-refs! rs (make-hasheq)) 179 (set-runstack-all-refs! rs #hasheq()) 180 (runstack-branch-state (hash-copy (runstack-need-inits rs)) 181 (runstack-sync-depth rs) 182 unsynced-refs 183 all-refs 184 (runstack-staged-clears rs))) 185 186(define (runstack-branch-other! rs pre) 187 (begin0 188 (runstack-branch-state (hash-copy (runstack-need-inits rs)) 189 (runstack-sync-depth rs) 190 (runstack-unsynced-refs rs) 191 (runstack-all-refs rs) 192 (runstack-staged-clears rs)) 193 (set-runstack-need-inits! rs (runstack-branch-state-need-inits pre)) 194 (set-runstack-sync-depth! rs (runstack-branch-state-sync-depth pre)) 195 (set-runstack-unsynced-refs! rs (make-hasheq)) 196 (set-runstack-all-refs! rs #hasheq()) 197 (set-runstack-staged-clears! rs (runstack-branch-state-staged-clears pre)))) 198 199;; Called after "then" branch, before merge: 200(define (runstack-branch-refs runstack pre post) 201 (values (runstack-branch-state-all-refs post) 202 (runstack-all-refs runstack))) 203 204(define (runstack-branch-merge! rs pre post) 205 (for ([(k v) (in-hash (runstack-branch-state-need-inits post))]) 206 (hash-set! (runstack-need-inits rs) k v)) 207 (unless (eqv? (runstack-branch-state-sync-depth post) (runstack-sync-depth rs)) 208 (set-runstack-sync-depth! rs #f)) 209 (set-runstack-unsynced-refs! rs (union-unsynced-refs! (runstack-unsynced-refs rs) 210 (runstack-branch-state-unsynced-refs pre) 211 (runstack-branch-state-unsynced-refs post))) 212 (set-runstack-all-refs! rs (union-all-refs (runstack-all-refs rs) 213 (runstack-branch-state-all-refs pre) 214 (runstack-branch-state-all-refs post))) 215 (set-runstack-staged-clears! rs (hash-union (runstack-staged-clears rs) 216 (runstack-branch-state-staged-clears post)))) 217 218(define union-unsynced-refs! 219 (case-lambda 220 [(a b c) 221 (cond 222 [((hash-count b) . > . (hash-count a)) 223 (union-unsynced-refs! b a c)] 224 [((hash-count c) . > . (hash-count b)) 225 (union-unsynced-refs! a c b)] 226 [else 227 (union-unsynced-refs! a b) 228 (union-unsynced-refs! a c)])] 229 [(a b) 230 (for ([(id l) (in-hash b)]) 231 (hash-set! a id (append l (hash-ref a id '())))) 232 a])) 233 234(define union-all-refs 235 (case-lambda 236 [(a b c) 237 (cond 238 [((hash-count b) . > . (hash-count a)) 239 (union-all-refs b a c)] 240 [((hash-count c) . > . (hash-count b)) 241 (union-all-refs a c b)] 242 [else 243 (union-all-refs (union-all-refs a b) c)])] 244 [(a b) 245 (for/fold ([a a]) ([(id b-refs) (in-hash b)]) 246 (define a-refs (hash-ref a id #hasheq())) 247 (hash-set a id (hash-union a-refs b-refs)))])) 248 249(define (hash-set2 ht key key2 val) 250 (hash-set ht key 251 (hash-set (hash-ref ht key #hasheq()) 252 key2 253 val))) 254 255;; ---------------------------------------- 256 257;; If `other-refs` includes a last use of a variable that 258;; is not referenced in `my-refs`, then stage a clear 259;; operation for space safety. The clear operation is emitted 260;; only if the variable is still live by the time the runstack 261;; is synced. 262(define (runstack-stage-clear-unused! rs my-refs other-refs state) 263 (for* ([refs (in-hash-values other-refs)] 264 [ref (in-hash-keys refs)]) 265 (define id (ref-id ref)) 266 (when (and (ref-last-use? ref) 267 (not (hash-ref my-refs id #f))) 268 (runstack-stage-clear! rs id state)))) 269 270;; A danger of lazy clearing is that we might push the same 271;; clearing operation to two different branches. It would be 272;; better to clear eagerly at the start of a branch if there 273;; will definitely by a sync point later, but we don't currently 274;; have the "sync point later?" information. 275(define (runstack-stage-clear! rs id state) 276 (set-runstack-staged-clears! 277 rs 278 (hash-set (runstack-staged-clears rs) 279 id 280 ;; the `get-pos` thunk: 281 (lambda () 282 (cond 283 [(not (referenced? (hash-ref state id #f))) 284 ;; This can happen in we need to clear a variable that is 285 ;; otherwise only implicitly passed in a tail call: 286 (format "-~a /* ~a */" (runstack-ref-pos rs id) (cify id))] 287 [else 288 (cify id)]))))) 289 290(define (runstack-generate-staged-clears! rs) 291 (for ([(id get-pos) (in-sorted-hash (runstack-staged-clears rs) symbol<?)]) 292 (unless (eq? (hash-ref (runstack-var-depths rs) id) 'local) 293 (out "c_no_use(c_runbase, ~a);" (get-pos)))) 294 (set-runstack-staged-clears! rs #hasheq())) 295