suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Chez Scheme: move cp machine-register indirection

Browse Source 
Register allocation needs fresh machine-register state for each
compilation, and that was previously implemented by allocating a new
register record and indirecting references through a parameter. Move
the indirection to the places where conflict-set, index, and precolor
state is manipulated, and pass a state vector though to keep access
efficient. This change makes compilation slightly faster, and it makes
registers easier to work with by not having to introduce
indirections/delays in various places for register references.
This commit is contained in:
Matthew Flatt 2021-03-14 09:56:26 -06:00
parent 467ca64a7f
commit c0cfd32bcb
6 changed files with 256 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
racket/src/ChezScheme/s/arm64.ss
View File

@ -2408,10 +2408,10 @@
(or (andmap double-member? members) (or (andmap double-member? members)
(andmap float-member? members)))))] (andmap float-member? members)))))]
[else #f])) [else #f]))
(define int-argument-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4 (define int-argument-regs (list %Carg1 %Carg2 %Carg3 %Carg4
%Carg5 %Carg6 %Carg7 %Carg8))) %Carg5 %Carg6 %Carg7 %Carg8))
(define fp-argument-regs (lambda () (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 (define fp-argument-regs (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4
%Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8))) %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8))
(define save-and-restore (define save-and-restore
(lambda (regs e) (lambda (regs e)
(safe-assert (andmap reg? regs)) (safe-assert (andmap reg? regs))
@ -2499,7 +2499,7 @@
(define categorize-arguments (define categorize-arguments
(lambda (types varargs-after) (lambda (types varargs-after)
(let loop ([types types] [int* (int-argument-regs)] [fp* (fp-argument-regs)] (let loop ([types types] [int* int-argument-regs] [fp* fp-argument-regs]
[varargs-after varargs-after] [varargs-after varargs-after]
;; accumulate alignment from previous args so we can compute any ;; accumulate alignment from previous args so we can compute any
;; needed padding and alignment after this next argument ;; needed padding and alignment after this next argument

230
racket/src/ChezScheme/s/cpnanopass.ss
View File

@ -8473,6 +8473,7 @@
(define-threaded max-fv) (define-threaded max-fv)
(define-threaded max-fs@call) (define-threaded max-fs@call)
(define-threaded poison-cset) (define-threaded poison-cset)
(define-threaded current-reg-spillinfo)
(define no-live* empty-tree) (define no-live* empty-tree)
@ -8486,18 +8487,18 @@
(tree-same? live1 live2))) (tree-same? live1 live2)))
(define live? (define live?
(lambda (live* live-size x) (lambda (live* live-size x reg-spillinfo)
(tree-bit-set? live* live-size (var-index x)))) (tree-bit-set? live* live-size (var-index x reg-spillinfo))))
(define get-live-vars (define get-live-vars
(lambda (live* live-size v) (lambda (live* live-size v)
(tree-extract live* live-size v))) (tree-extract live* live-size v)))
(define make-add-var (define make-add-var
(lambda (live-size) (lambda (live-size reg-spillinfo)
; add x to live*. result is eq? to live* if x is already in live*. ; add x to live*. result is eq? to live* if x is already in live*.
(lambda (live* x) (lambda (live* x)
(let ([index (var-index x)]) (let ([index (var-index x reg-spillinfo)])
(if index (if index
(let ([new (tree-bit-set live* live-size index)]) (let ([new (tree-bit-set live* live-size index)])
(safe-assert (or (eq? new live*) (not (tree-same? new live*)))) (safe-assert (or (eq? new live*) (not (tree-same? new live*))))
@ -8506,11 +8507,11 @@
(define make-remove-var (define make-remove-var
; remove x from live*. result is eq? to live* if x is not in live*. ; remove x from live*. result is eq? to live* if x is not in live*.
(lambda (live-size) (lambda (live-size reg-spillinfo)
(lambda (live* x) (lambda (live* x)
(let ([index (var-index x)]) (let ([index (var-index x reg-spillinfo)])
(if index (if index
(let ([new (tree-bit-unset live* live-size (var-index x))]) (let ([new (tree-bit-unset live* live-size (var-index x reg-spillinfo))])
(safe-assert (or (eq? new live*) (not (tree-same? new live*)))) (safe-assert (or (eq? new live*) (not (tree-same? new live*))))
new) new)
live*))))) live*)))))
@ -8580,9 +8581,9 @@
[(1) #t]))) [(1) #t])))
(define do-live-analysis! (define do-live-analysis!
(lambda (live-size entry-block*) (lambda (live-size entry-block* reg-spillinfo)
(define add-var (make-add-var live-size)) (define add-var (make-add-var live-size reg-spillinfo))
(define remove-var (make-remove-var live-size)) (define remove-var (make-remove-var live-size reg-spillinfo))
(define-who scan-block (define-who scan-block
; if we maintain a list of kills and a list of useless variables for ; if we maintain a list of kills and a list of useless variables for
; each block, and we discover on entry to scan-block that the useless ; each block, and we discover on entry to scan-block that the useless
@ -8638,7 +8639,7 @@
(lambda (out instr) (lambda (out instr)
(nanopass-case (L15a Effect) instr (nanopass-case (L15a Effect) instr
[(set! ,live-info ,x ,rhs) [(set! ,live-info ,x ,rhs)
(if (var-index x) (if (var-index x reg-spillinfo)
(let ([new-out (remove-var out x)]) (let ([new-out (remove-var out x)])
(if (and (eq? new-out out) (if (and (eq? new-out out)
(nanopass-case (L15a Rhs) rhs (nanopass-case (L15a Rhs) rhs
@ -8888,11 +8889,11 @@
(refine (fxsrl skip 1) skip))))))) (refine (fxsrl skip 1) skip)))))))
(define-who do-spillable-conflict! (define-who do-spillable-conflict!
(lambda (kspillable kfv varvec live-size block*) (lambda (kspillable reg-spillinfo kfv varvec live-size block*)
(define remove-var (make-remove-var live-size)) (define remove-var (make-remove-var live-size reg-spillinfo))
(define add-move! (define add-move!
(lambda (x1 x2) (lambda (x1 x2)
(when (var-index x2) (when (var-index x2 reg-spillinfo)
($add-move! x1 x2 2) ($add-move! x1 x2 2)
($add-move! x2 x1 2)))) ($add-move! x2 x1 2))))
(define add-conflict! (define add-conflict!
@ -8900,14 +8901,14 @@
; invariants: ; invariants:
; all poison spillables explicitly point to all spillables ; all poison spillables explicitly point to all spillables
; all non-poison spillables implicitly point to all poison spillables via poison-cset ; all non-poison spillables implicitly point to all poison spillables via poison-cset
(let ([x-offset (var-index x)]) (let ([x-offset (var-index x reg-spillinfo)])
(when x-offset (when x-offset
(if (and (fx< x-offset kspillable) (uvar-poison? x)) (if (and (fx< x-offset kspillable) (uvar-poison? x))
(tree-for-each out live-size kspillable (fx+ kspillable kfv) (tree-for-each out live-size kspillable (fx+ kspillable kfv)
(lambda (y-offset) (lambda (y-offset)
; frame y -> poison spillable x ; frame y -> poison spillable x
(conflict-bit-set! (var-spillable-conflict* (vector-ref varvec y-offset)) x-offset))) (conflict-bit-set! (var-spillable-conflict* (vector-ref varvec y-offset) reg-spillinfo) x-offset)))
(let ([cset (var-spillable-conflict* x)]) (let ([cset (var-spillable-conflict* x reg-spillinfo)])
(if (fx< x-offset kspillable) (if (fx< x-offset kspillable)
(begin (begin
(tree-for-each out live-size 0 kspillable (tree-for-each out live-size 0 kspillable
@ -8917,12 +8918,12 @@
; non-poison spillable x -> non-poison spillable y ; non-poison spillable x -> non-poison spillable y
(conflict-bit-set! cset y-offset) (conflict-bit-set! cset y-offset)
; and vice versa ; and vice versa
(conflict-bit-set! (var-spillable-conflict* y) x-offset))))) (conflict-bit-set! (var-spillable-conflict* y reg-spillinfo) x-offset)))))
(tree-for-each out live-size kspillable live-size (tree-for-each out live-size kspillable live-size
(lambda (y-offset) (lambda (y-offset)
(let ([y (vector-ref varvec y-offset)]) (let ([y (vector-ref varvec y-offset)])
; frame or register y -> non-poison spillable x ; frame or register y -> non-poison spillable x
(conflict-bit-set! (var-spillable-conflict* y) x-offset))))) (conflict-bit-set! (var-spillable-conflict* y reg-spillinfo) x-offset)))))
(if (fx< x-offset (fx+ kspillable kfv)) (if (fx< x-offset (fx+ kspillable kfv))
(tree-for-each out live-size 0 kspillable (tree-for-each out live-size 0 kspillable
(lambda (y-offset) (lambda (y-offset)
@ -8947,8 +8948,8 @@
(if (live-info-useless live-info) (if (live-info-useless live-info)
new-effect* new-effect*
(let ([live (live-info-live live-info)]) (let ([live (live-info-live live-info)])
(when (var-index x) (when (var-index x reg-spillinfo)
(if (and (var? rhs) (var-index rhs)) (if (and (var? rhs) (var-index rhs reg-spillinfo))
(begin (begin
(add-conflict! x (remove-var live rhs)) (add-conflict! x (remove-var live rhs))
(add-move! x rhs)) (add-move! x rhs))
@ -8970,11 +8971,11 @@
(conflict-bit-set! poison-cset i) (conflict-bit-set! poison-cset i)
; leaving each poison spillable in conflict with itself, but this shouldn't matter ; leaving each poison spillable in conflict with itself, but this shouldn't matter
; since we never ask for the degree of a poison spillable ; since we never ask for the degree of a poison spillable
(var-spillable-conflict*-set! x (make-full-cset kspillable))) (var-spillable-conflict*-set! x reg-spillinfo (make-full-cset kspillable)))
(var-spillable-conflict*-set! x (make-empty-cset kspillable))))) (var-spillable-conflict*-set! x reg-spillinfo (make-empty-cset kspillable)))))
(do ([i kspillable (fx+ i 1)]) (do ([i kspillable (fx+ i 1)])
((fx= i live-size)) ((fx= i live-size))
(var-spillable-conflict*-set! (vector-ref varvec i) (make-empty-cset kspillable))) (var-spillable-conflict*-set! (vector-ref varvec i) reg-spillinfo (make-empty-cset kspillable)))
(for-each (for-each
(lambda (block) (lambda (block)
(block-effect*-set! block (block-effect*-set! block
@ -8982,15 +8983,15 @@
block*))) block*)))
(define-who show-conflicts (define-who show-conflicts
(lambda (name varvec unvarvec) (lambda (name varvec unvarvec reg-spillinfo)
(define any? #f) (define any? #f)
(printf "\n~s conflicts:" name) (printf "\n~s conflicts:" name)
(for-each (for-each
(lambda (x) (lambda (x)
(let ([ls (append (let ([ls (append
(let ([cset (var-spillable-conflict* x)]) (let ([cset (var-spillable-conflict* x reg-spillinfo)])
(if cset (extract-conflicts cset varvec) '())) (if cset (extract-conflicts cset varvec) '()))
(let ([cset (var-unspillable-conflict* x)]) (let ([cset (var-unspillable-conflict* x reg-spillinfo)])
(if cset (extract-conflicts cset unvarvec) '())))]) (if cset (extract-conflicts cset unvarvec) '())))])
(unless (null? ls) (set! any? #t) (printf "\n~s:~{ ~s~}" x ls)))) (unless (null? ls) (set! any? #t) (printf "\n~s:~{ ~s~}" x ls))))
(append spillable* unspillable* (vector->list regvec) (map get-fv (iota (fx+ max-fv 1))))) (append spillable* unspillable* (vector->list regvec) (map get-fv (iota (fx+ max-fv 1)))))
@ -8999,19 +9000,19 @@
(module (assign-frame! assign-new-frame!) (module (assign-frame! assign-new-frame!)
(define update-conflict! (define update-conflict!
(lambda (fv spill) (lambda (fv spill reg-spillinfo)
(let ([cset1 (var-spillable-conflict* fv)] (let ([cset1 (var-spillable-conflict* fv reg-spillinfo)]
[cset2 (var-spillable-conflict* spill)]) [cset2 (var-spillable-conflict* spill reg-spillinfo)])
(if cset1 (if cset1
(cset-merge! cset1 cset2) (cset-merge! cset1 cset2)
; tempting to set to cset2 rather than (cset-copy cset2), but this would not be ; tempting to set to cset2 rather than (cset-copy cset2), but this would not be
; correct for local saves, which need their unaltered sets for later, and copying ; correct for local saves, which need their unaltered sets for later, and copying
; is cheap anyway. ; is cheap anyway.
(var-spillable-conflict*-set! fv (cset-copy cset2)))) (var-spillable-conflict*-set! fv reg-spillinfo (cset-copy cset2))))
(unless (uvar-poison? spill) (cset-merge! (var-spillable-conflict* fv) poison-cset)))) (unless (uvar-poison? spill) (cset-merge! (var-spillable-conflict* fv reg-spillinfo) poison-cset))))
(define assign-frame! (define assign-frame!
(lambda (spill*) (lambda (spill* reg-spillinfo)
(define sort-spill* (define sort-spill*
; NB: sorts based on likelihood of successfully assigning move-related vars to the same location ; NB: sorts based on likelihood of successfully assigning move-related vars to the same location
; NB: probably should sort based on value of assigning move-related vars to the same location, ; NB: probably should sort based on value of assigning move-related vars to the same location,
@ -9035,8 +9036,8 @@
(lambda (x0 succ fail) (lambda (x0 succ fail)
(define conflict-fv? (define conflict-fv?
(lambda (x fv) (lambda (x fv)
(let ([cset (var-spillable-conflict* fv)]) (let ([cset (var-spillable-conflict* fv reg-spillinfo)])
(and cset (conflict-bit-set? cset (var-index x)))))) (and cset (conflict-bit-set? cset (var-index x reg-spillinfo))))))
(let f ([x x0] [work* '()] [clear-seen! void]) (let f ([x x0] [work* '()] [clear-seen! void])
(if (uvar-seen? x) (if (uvar-seen? x)
(if (null? work*) (begin (clear-seen!) (fail)) (f (car work*) (cdr work*) clear-seen!)) (if (null? work*) (begin (clear-seen!) (fail)) (f (car work*) (cdr work*) clear-seen!))
@ -9067,7 +9068,7 @@
(lambda (home max-fv first-open) (lambda (home max-fv first-open)
(safe-assert (compatible-fv? home (uvar-type spill))) (safe-assert (compatible-fv? home (uvar-type spill)))
(uvar-location-set! spill home) (uvar-location-set! spill home)
(update-conflict! home spill) (update-conflict! home spill reg-spillinfo)
(let ([max-fv (let ([max-fv
(constant-case ptr-bits (constant-case ptr-bits
[(32) [(32)
@ -9084,14 +9085,14 @@
(lambda (home) (return home max-fv first-open)) (lambda (home) (return home max-fv first-open))
(lambda () (lambda ()
(let f ([first-open first-open]) (let f ([first-open first-open])
(let* ([fv (get-fv first-open (uvar-type spill))] [cset (var-spillable-conflict* fv)]) (let* ([fv (get-fv first-open (uvar-type spill))] [cset (var-spillable-conflict* fv reg-spillinfo)])
(if (and cset (cset-full? cset)) (if (and cset (cset-full? cset))
(f (fx+ first-open 1)) (f (fx+ first-open 1))
(let ([spill-offset (var-index spill)]) (let ([spill-offset (var-index spill reg-spillinfo)])
(let f ([fv-offset first-open] [fv fv] [cset cset]) (let f ([fv-offset first-open] [fv fv] [cset cset])
(if (or (and cset (conflict-bit-set? cset spill-offset)) (if (or (and cset (conflict-bit-set? cset spill-offset))
(not (compatible-fv? fv (uvar-type spill)))) (not (compatible-fv? fv (uvar-type spill))))
(let* ([fv-offset (fx+ fv-offset 1)] [fv (get-fv fv-offset (uvar-type spill))] [cset (var-spillable-conflict* fv)]) (let* ([fv-offset (fx+ fv-offset 1)] [fv (get-fv fv-offset (uvar-type spill))] [cset (var-spillable-conflict* fv reg-spillinfo)])
(f fv-offset fv cset)) (f fv-offset fv cset))
(return fv (fxmax fv-offset max-fv) first-open))))))))))) (return fv (fxmax fv-offset max-fv) first-open)))))))))))
(define find-homes! (define find-homes!
@ -9106,9 +9107,9 @@
; live across only a few (only when setup-nfv?) ; live across only a few (only when setup-nfv?)
(set! max-fv (find-homes! (sort-spill* spill*) max-fv 1)))) (set! max-fv (find-homes! (sort-spill* spill*) max-fv 1))))
(define-pass assign-new-frame! : (L15a Dummy) (ir lambda-info live-size varvec block*) -> (L15b Dummy) () (define-pass assign-new-frame! : (L15a Dummy) (ir lambda-info live-size varvec reg-spillinfo block*) -> (L15b Dummy) ()
(definitions (definitions
(define remove-var (make-remove-var live-size)) (define remove-var (make-remove-var live-size reg-spillinfo))
(define find-max-fv (define find-max-fv
(lambda (call-live*) (lambda (call-live*)
(fold-left (fold-left
@ -9122,8 +9123,8 @@
(and (or (not (car nfv*)) (and (or (not (car nfv*))
(let ([fv (get-fv offset)]) (let ([fv (get-fv offset)])
(and (compatible-fv? fv 'ptr) (and (compatible-fv? fv 'ptr)
(let ([cset (var-spillable-conflict* fv)]) (let ([cset (var-spillable-conflict* fv reg-spillinfo)])
(not (and cset (conflict-bit-set? cset (var-index (car nfv*))))))))) (not (and cset (conflict-bit-set? cset (var-index (car nfv*) reg-spillinfo))))))))
(loop (cdr nfv*) (fx+ offset 1))))))) (loop (cdr nfv*) (fx+ offset 1)))))))
(define assign-new-frame! (define assign-new-frame!
(lambda (cnfv* nfv** call-live*) (lambda (cnfv* nfv** call-live*)
@ -9134,7 +9135,7 @@
(let* ([nfv (car nfv*)] [home (get-fv offset (uvar-type nfv))]) (let* ([nfv (car nfv*)] [home (get-fv offset (uvar-type nfv))])
(safe-assert (compatible-fv? home (uvar-type nfv))) (safe-assert (compatible-fv? home (uvar-type nfv)))
(uvar-location-set! nfv home) (uvar-location-set! nfv home)
(update-conflict! home nfv) (update-conflict! home nfv reg-spillinfo)
(set-offsets! (cdr nfv*) (fx+ offset 1)))))) (set-offsets! (cdr nfv*) (fx+ offset 1))))))
(let ([arg-offset (fx+ (length cnfv*) 1)]) ; +1 for return address slot (let ([arg-offset (fx+ (length cnfv*) 1)]) ; +1 for return address slot
(let loop ([base (fx+ (find-max-fv call-live*) 1)]) (let loop ([base (fx+ (find-max-fv call-live*) 1)])
@ -9246,7 +9247,7 @@
[(restore-local-saves ,live-info ,info) [(restore-local-saves ,live-info ,info)
(with-output-language (L15b Effect) (with-output-language (L15b Effect)
(let ([live (live-info-live live-info)]) (let ([live (live-info-live live-info)])
(let loop ([x* (filter (lambda (x) (live? live live-size x)) (info-newframe-local-save* info))] (let loop ([x* (filter (lambda (x) (live? live live-size x reg-spillinfo)) (info-newframe-local-save* info))]
[live live] [live live]
[new-effect* new-effect*]) [new-effect* new-effect*])
(if (null? x*) (if (null? x*)
@ -9292,7 +9293,8 @@
[(newframe-block? block) [(newframe-block? block)
(let ([info (newframe-block-info block)]) (let ([info (newframe-block-info block)])
(process-info-newframe! info) (process-info-newframe! info)
(safe-assert (andmap (lambda (x) (live? (newframe-block-live-call block) live-size x)) (info-newframe-local-save* info))) (safe-assert (andmap (lambda (x) (live? (newframe-block-live-call block) live-size x reg-spillinfo))
(info-newframe-local-save* info)))
(with-output-language (L15b Effect) (with-output-language (L15b Effect)
(let ([live (newframe-block-live-out block)]) (let ([live (newframe-block-live-out block)])
(fold-left (fold-left
@ -9415,7 +9417,8 @@
(define make-restricted-unspillable (define make-restricted-unspillable
(lambda (x reg*) (lambda (x reg*)
(import (only np-languages make-restricted-unspillable)) (import (only np-languages make-restricted-unspillable))
(safe-assert (andmap reg? reg*) (andmap var-index reg*)) (safe-assert (andmap reg? reg*)
(andmap (lambda (r) (var-index r current-reg-spillinfo)) reg*))
(let ([tmp (make-restricted-unspillable x reg*)]) (let ([tmp (make-restricted-unspillable x reg*)])
(set! unspillable* (cons tmp unspillable*)) (set! unspillable* (cons tmp unspillable*))
tmp))) tmp)))
@ -9425,11 +9428,12 @@
; for correct code but causes a spilled unspillable error if we try to use the same ; for correct code but causes a spilled unspillable error if we try to use the same
; machine register for two conflicting variables ; machine register for two conflicting variables
(lambda (name reg) (lambda (name reg)
(or (reg-precolored reg) (let ([reg-spillinfo current-reg-spillinfo])
(let ([tmp (make-restricted-unspillable name (remq reg (vector->list regvec)))]) (or (reg-precolored reg reg-spillinfo)
(safe-assert (memq reg (vector->list regvec))) (let ([tmp (make-restricted-unspillable name (remq reg (vector->list regvec)))])
(reg-precolored-set! reg tmp) (safe-assert (memq reg (vector->list regvec)))
tmp)))) (reg-precolored-set! reg reg-spillinfo tmp)
tmp)))))
(define-syntax build-set! (define-syntax build-set!
(lambda (x) (lambda (x)
@ -9737,10 +9741,10 @@
[(k context (sym ...) cl ...) #'(k context (sym ...) (definitions) cl ...)] [(k context (sym ...) cl ...) #'(k context (sym ...) (definitions) cl ...)]
[(k context sym cl ...) (identifier? #'sym) #'(k context (sym) (definitions) cl ...)]))) [(k context sym cl ...) (identifier? #'sym) #'(k context (sym) (definitions) cl ...)])))
(define-pass select-instructions! : (L15c Dummy) (ir block* live-size force-overflow?) -> (L15d Dummy) () (define-pass select-instructions! : (L15c Dummy) (ir block* live-size reg-spillinfo force-overflow?) -> (L15d Dummy) ()
(definitions (definitions
(module (handle-jump handle-effect-inline handle-pred-inline handle-value-inline) (module (handle-jump handle-effect-inline handle-pred-inline handle-value-inline)
(define add-var (make-add-var live-size)) (define add-var (make-add-var live-size reg-spillinfo))
(define Triv (define Triv
(lambda (out t) (lambda (out t)
(nanopass-case (L15d Triv) t (nanopass-case (L15d Triv) t
@ -9927,8 +9931,8 @@
) )
(define-who do-unspillable-conflict! (define-who do-unspillable-conflict!
(lambda (kfv kspillable varvec live-size kunspillable unvarvec block*) (lambda (kfv kspillable reg-spillinfo varvec live-size kunspillable unvarvec block*)
(define remove-var (make-remove-var live-size)) (define remove-var (make-remove-var live-size reg-spillinfo))
(define unspillable? (define unspillable?
(lambda (x) (lambda (x)
(and (uvar? x) (uvar-unspillable? x)))) (and (uvar? x) (uvar-unspillable? x))))
@ -9941,26 +9945,26 @@
unspillable*))) unspillable*)))
(define add-move! (define add-move!
(lambda (x1 x2) (lambda (x1 x2)
(when (var-index x2) (when (var-index x2 reg-spillinfo)
($add-move! x1 x2 2) ($add-move! x1 x2 2)
($add-move! x2 x1 2)))) ($add-move! x2 x1 2))))
(define add-move-hint! (define add-move-hint!
(lambda (x1 x2) (lambda (x1 x2)
(when (var-index x2) (when (var-index x2 reg-spillinfo)
($add-move! x1 x2 1) ($add-move! x1 x2 1)
($add-move! x2 x1 1)))) ($add-move! x2 x1 1))))
(define add-static-conflict! (define add-static-conflict!
(lambda (u reg*) (lambda (u reg*)
(let ([u-offset (var-index u)]) (let ([u-offset (var-index u reg-spillinfo)])
(for-each (for-each
(lambda (reg) (conflict-bit-set! (var-unspillable-conflict* reg) u-offset)) (lambda (reg) (conflict-bit-set! (var-unspillable-conflict* reg reg-spillinfo) u-offset))
reg*)))) reg*))))
(define add-us->s-conflicts! (define add-us->s-conflicts!
(lambda (x out) ; x is an unspillable (lambda (x out) ; x is an unspillable
(let ([x-offset (var-index x)] [cset (var-spillable-conflict* x)]) (let ([x-offset (var-index x reg-spillinfo)] [cset (var-spillable-conflict* x reg-spillinfo)])
(tree-for-each out live-size 0 live-size (tree-for-each out live-size 0 live-size
(lambda (y-offset) (lambda (y-offset)
(let* ([y (vector-ref varvec y-offset)] [y-cset (var-unspillable-conflict* y)]) (let* ([y (vector-ref varvec y-offset)] [y-cset (var-unspillable-conflict* y reg-spillinfo)])
(when y-cset (when y-cset
; if y is a spillable, point the unspillable x at y ; if y is a spillable, point the unspillable x at y
(when (fx< y-offset kspillable) (conflict-bit-set! cset y-offset)) (when (fx< y-offset kspillable) (conflict-bit-set! cset y-offset))
@ -9968,23 +9972,23 @@
(conflict-bit-set! y-cset x-offset)))))))) (conflict-bit-set! y-cset x-offset))))))))
(define add-us->us-conflicts! (define add-us->us-conflicts!
(lambda (x unspillable*) ; x is a unspillable (lambda (x unspillable*) ; x is a unspillable
(let ([x-offset (var-index x)] [cset (var-unspillable-conflict* x)]) (let ([x-offset (var-index x reg-spillinfo)] [cset (var-unspillable-conflict* x reg-spillinfo)])
(for-each (for-each
(lambda (y) (lambda (y)
(let ([y-offset (var-index y)]) (let ([y-offset (var-index y reg-spillinfo)])
(conflict-bit-set! cset y-offset) (conflict-bit-set! cset y-offset)
(conflict-bit-set! (var-unspillable-conflict* y) x-offset))) (conflict-bit-set! (var-unspillable-conflict* y reg-spillinfo) x-offset)))
unspillable*)))) unspillable*))))
(define add-s->us-conflicts! (define add-s->us-conflicts!
(lambda (x unspillable*) ; x is a spillable or register (lambda (x unspillable*) ; x is a spillable or register
(let ([x-offset (var-index x)] [cset (var-unspillable-conflict* x)]) (let ([x-offset (var-index x reg-spillinfo)] [cset (var-unspillable-conflict* x reg-spillinfo)])
(for-each (for-each
(lambda (y) (lambda (y)
(let ([y-offset (var-index y)]) (let ([y-offset (var-index y reg-spillinfo)])
; point x at unspillable y ; point x at unspillable y
(conflict-bit-set! cset y-offset) (conflict-bit-set! cset y-offset)
; if x is a spillable, point unspillable y at x ; if x is a spillable, point unspillable y at x
(when (fx< x-offset kspillable) (conflict-bit-set! (var-spillable-conflict* y) x-offset)))) (when (fx< x-offset kspillable) (conflict-bit-set! (var-spillable-conflict* y reg-spillinfo) x-offset))))
unspillable*)))) unspillable*))))
(define Triv (define Triv
(lambda (unspillable* t) (lambda (unspillable* t)
@ -10021,7 +10025,7 @@
(let ([unspillable* (remq x unspillable*)]) (let ([unspillable* (remq x unspillable*)])
(safe-assert (uvar-seen? x)) (safe-assert (uvar-seen? x))
(uvar-seen! x #f) (uvar-seen! x #f)
(if (and (var? rhs) (var-index rhs)) (if (and (var? rhs) (var-index rhs reg-spillinfo))
(begin (begin
(if (unspillable? rhs) (if (unspillable? rhs)
(begin (begin
@ -10036,7 +10040,7 @@
(add-us->s-conflicts! x spillable-live))) (add-us->s-conflicts! x spillable-live)))
(Rhs unspillable* rhs)) (Rhs unspillable* rhs))
(begin (begin
(when (var-unspillable-conflict* x) (when (var-unspillable-conflict* x reg-spillinfo)
(if (unspillable? rhs) (if (unspillable? rhs)
(begin (begin
(add-s->us-conflicts! x (remq rhs unspillable*)) (add-s->us-conflicts! x (remq rhs unspillable*))
@ -10048,8 +10052,8 @@
[(move-related ,x1 ,x2) (add-move-hint! x1 x2) unspillable*] [(move-related ,x1 ,x2) (add-move-hint! x1 x2) unspillable*]
[(overflow-check ,p ,e* ...) (Effect* (reverse e*) '()) (Pred p)] [(overflow-check ,p ,e* ...) (Effect* (reverse e*) '()) (Pred p)]
[else unspillable*]))))) [else unspillable*])))))
(for-each (lambda (x) (var-spillable-conflict*-set! x (make-empty-cset kspillable))) unspillable*) (for-each (lambda (x) (var-spillable-conflict*-set! x reg-spillinfo (make-empty-cset kspillable))) unspillable*)
(let ([f (lambda (x) (var-unspillable-conflict*-set! x (make-empty-cset kunspillable)))]) (let ([f (lambda (x) (var-unspillable-conflict*-set! x reg-spillinfo (make-empty-cset kunspillable)))])
(vector-for-each f regvec) (vector-for-each f regvec)
(for-each f spillable*) (for-each f spillable*)
(vector-for-each f unvarvec)) (vector-for-each f unvarvec))
@ -10065,7 +10069,7 @@
block*))) block*)))
(define-who assign-registers! (define-who assign-registers!
(lambda (lambda-info varvec unvarvec) (lambda (lambda-info varvec unvarvec reg-spillinfo)
(define total-k (vector-length regvec)) (define total-k (vector-length regvec))
(define fp-k (length extra-fpregisters)) (define fp-k (length extra-fpregisters))
(define ptr-k (- total-k fp-k)) (define ptr-k (- total-k fp-k))
@ -10089,18 +10093,18 @@
(uvar-degree-set! x (uvar-degree-set! x
(fx+ (fx+
; spills have been trimmed from the var-spillable-conflict* sets ; spills have been trimmed from the var-spillable-conflict* sets
(conflict-bit-count (var-spillable-conflict* x)) (conflict-bit-count (var-spillable-conflict* x reg-spillinfo))
(conflict-bit-count (var-unspillable-conflict* x))))) (conflict-bit-count (var-unspillable-conflict* x reg-spillinfo)))))
x*) x*)
; account for reg -> uvar conflicts ; account for reg -> uvar conflicts
(vector-for-each (vector-for-each
(lambda (reg) (lambda (reg)
(cset-for-each (var-spillable-conflict* reg) (cset-for-each (var-spillable-conflict* reg reg-spillinfo)
(lambda (x-offset) (lambda (x-offset)
(let ([x (vector-ref varvec x-offset)]) (let ([x (vector-ref varvec x-offset)])
(unless (uvar-location x) (unless (uvar-location x)
(uvar-degree-set! x (fx+ (uvar-degree x) 1)))))) (uvar-degree-set! x (fx+ (uvar-degree x) 1))))))
(cset-for-each (var-unspillable-conflict* reg) (cset-for-each (var-unspillable-conflict* reg reg-spillinfo)
(lambda (x-offset) (lambda (x-offset)
(let ([x (vector-ref unvarvec x-offset)]) (let ([x (vector-ref unvarvec x-offset)])
(uvar-degree-set! x (fx+ (uvar-degree x) 1)))))) (uvar-degree-set! x (fx+ (uvar-degree x) 1))))))
@ -10110,8 +10114,8 @@
(define conflict? (define conflict?
(lambda (reg x) (lambda (reg x)
(or (not (compatible-var-types? (reg-type reg) (uvar-type x))) (or (not (compatible-var-types? (reg-type reg) (uvar-type x)))
(let ([cset (if (uvar-unspillable? x) (var-unspillable-conflict* reg) (var-spillable-conflict* reg))]) (let ([cset (if (uvar-unspillable? x) (var-unspillable-conflict* reg reg-spillinfo) (var-spillable-conflict* reg reg-spillinfo))])
(conflict-bit-set? cset (var-index x)))))) (conflict-bit-set? cset (var-index x reg-spillinfo))))))
(define find-move-related-home (define find-move-related-home
(lambda (x0 succ fail) (lambda (x0 succ fail)
(let f ([x x0] [work* '()] [clear-seen! void]) (let f ([x x0] [work* '()] [clear-seen! void])
@ -10140,8 +10144,8 @@
(lambda (home) (lambda (home)
(define update-conflict! (define update-conflict!
(lambda (reg x) (lambda (reg x)
(cset-merge! (var-spillable-conflict* reg) (var-spillable-conflict* x)) (cset-merge! (var-spillable-conflict* reg reg-spillinfo) (var-spillable-conflict* x reg-spillinfo))
(cset-merge! (var-unspillable-conflict* reg) (var-unspillable-conflict* x)))) (cset-merge! (var-unspillable-conflict* reg reg-spillinfo) (var-unspillable-conflict* x reg-spillinfo))))
(uvar-location-set! x home) (uvar-location-set! x home)
(update-conflict! home x))) (update-conflict! home x)))
(find-move-related-home x (find-move-related-home x
@ -10177,11 +10181,11 @@
(values x (remq x x*))))) (values x (remq x x*)))))
(define remove-victim! (define remove-victim!
(lambda (victim) (lambda (victim)
(cset-for-each (var-spillable-conflict* victim) (cset-for-each (var-spillable-conflict* victim reg-spillinfo)
(lambda (offset) (lambda (offset)
(let ([x (vector-ref varvec offset)]) (let ([x (vector-ref varvec offset)])
(uvar-degree-set! x (fx- (uvar-degree x) 1))))) (uvar-degree-set! x (fx- (uvar-degree x) 1)))))
(cset-for-each (var-unspillable-conflict* victim) (cset-for-each (var-unspillable-conflict* victim reg-spillinfo)
(lambda (offset) (lambda (offset)
(let ([x (vector-ref unvarvec offset)]) (let ([x (vector-ref unvarvec offset)])
(uvar-degree-set! x (fx- (uvar-degree x) 1))))))) (uvar-degree-set! x (fx- (uvar-degree x) 1)))))))
@ -10438,16 +10442,17 @@
[(_ ?unparser pass-name ?arg ...) [(_ ?unparser pass-name ?arg ...)
#'(xpass pass-name (RAprinter ?unparser) (list ?arg ...))])))) #'(xpass pass-name (RAprinter ?unparser) (list ?arg ...))]))))
(safe-assert (andmap (lambda (x) (eq? (uvar-location x) #f)) local*)) (safe-assert (andmap (lambda (x) (eq? (uvar-location x) #f)) local*))
(let ([kspillable (length local*)] [kfv (fx+ max-fv0 1)] [kreg (vector-length regvec)]) (let ([kspillable (length local*)] [kfv (fx+ max-fv0 1)] [kreg (vector-length regvec)] [reg-spillinfo (make-reg-spillinfo)])
(fluid-let ([spillable* local*] [unspillable* '()] [max-fv max-fv0] [max-fs@call 0] [poison-cset (make-empty-cset kspillable)]) (fluid-let ([spillable* local*] [unspillable* '()] [max-fv max-fv0] [max-fs@call 0]
[poison-cset (make-empty-cset kspillable)] [current-reg-spillinfo reg-spillinfo])
(let* ([live-size (fx+ kfv kreg kspillable)] [varvec (make-vector live-size)]) (let* ([live-size (fx+ kfv kreg kspillable)] [varvec (make-vector live-size)])
; set up var indices & varvec mapping from indices to vars ; set up var indices & varvec mapping from indices to vars
(fold-left (lambda (i x) (var-index-set! x i) (vector-set! varvec i x) (fx+ i 1)) 0 spillable*) (fold-left (lambda (i x) (var-index-set! x i) (vector-set! varvec i x) (fx+ i 1)) 0 spillable*)
(do ([i 0 (fx+ i 1)]) ((fx= i kfv)) (let ([fv (get-fv i)] [i (fx+ i kspillable)]) (var-index-set! fv i) (vector-set! varvec i fv))) (do ([i 0 (fx+ i 1)]) ((fx= i kfv)) (let ([fv (get-fv i)] [i (fx+ i kspillable)]) (var-index-set! fv i) (vector-set! varvec i fv)))
(do ([i 0 (fx+ i 1)]) ((fx= i kreg)) (let ([reg (vector-ref regvec i)] [i (fx+ i kspillable kfv)]) (var-index-set! reg i) (vector-set! varvec i reg))) (do ([i 0 (fx+ i 1)]) ((fx= i kreg)) (let ([reg (vector-ref regvec i)] [i (fx+ i kspillable kfv)]) (var-index-set! reg reg-spillinfo i) (vector-set! varvec i reg)))
(with-live-info-record-writer live-size varvec (with-live-info-record-writer live-size varvec
; run intra/inter-block live analysis ; run intra/inter-block live analysis
(RApass unparse-L15a do-live-analysis! live-size entry-block*) (RApass unparse-L15a do-live-analysis! live-size entry-block* reg-spillinfo)
; this is worth enabling from time to time... ; this is worth enabling from time to time...
#;(check-entry-live! (info-lambda-name info) live-size varvec entry-block*) #;(check-entry-live! (info-lambda-name info) live-size varvec entry-block*)
; rerun intra-block live analysis and record (fv v reg v spillable) x spillable conflicts ; rerun intra-block live analysis and record (fv v reg v spillable) x spillable conflicts
@ -10455,64 +10460,64 @@
;; NB: we could just use (vector-length varvec) to get live-size ;; NB: we could just use (vector-length varvec) to get live-size
(when (fx> kspillable 1000) ; NB: parameter? (when (fx> kspillable 1000) ; NB: parameter?
(RApass unparse-L15a identify-poison! kspillable varvec live-size block*)) (RApass unparse-L15a identify-poison! kspillable varvec live-size block*))
(RApass unparse-L15a do-spillable-conflict! kspillable kfv varvec live-size block*) (RApass unparse-L15a do-spillable-conflict! kspillable reg-spillinfo kfv varvec live-size block*)
#;(show-conflicts (info-lambda-name info) varvec '#()) #;(show-conflicts (info-lambda-name info) varvec '#() reg-spillinfo)
; find frame homes for call-live variables; adds new fv x spillable conflicts ; find frame homes for call-live variables; adds new fv x spillable conflicts
(RApass unparse-L15a assign-frame! (filter uvar-spilled? spillable*)) (RApass unparse-L15a assign-frame! (filter uvar-spilled? spillable*) reg-spillinfo)
#;(show-homes) #;(show-homes)
(RApass unparse-L15a record-inspector-information! info) (RApass unparse-L15a record-inspector-information! info)
; determine frame sizes at nontail-call sites and assign homes to new-frame variables ; determine frame sizes at nontail-call sites and assign homes to new-frame variables
; adds new fv x spillable conflicts ; adds new fv x spillable conflicts
(let ([dummy (RApass unparse-L15b assign-new-frame! (with-output-language (L15a Dummy) `(dummy)) info live-size varvec block*)]) (let ([dummy (RApass unparse-L15b assign-new-frame! (with-output-language (L15a Dummy) `(dummy)) info live-size varvec reg-spillinfo block*)])
; record fp offset on entry to each block ; record fp offset on entry to each block
(RApass unparse-L15b record-fp-offsets! entry-block*) (RApass unparse-L15b record-fp-offsets! entry-block*)
; assign frame homes to poison variables ; assign frame homes to poison variables
(let ([spill* (filter (lambda (x) (and (not (uvar-location x)) (uvar-poison? x))) spillable*)]) (let ([spill* (filter (lambda (x) (and (not (uvar-location x)) (uvar-poison? x))) spillable*)])
(unless (null? spill*) (unless (null? spill*)
(for-each (lambda (x) (uvar-spilled! x #t)) spill*) (for-each (lambda (x) (uvar-spilled! x #t)) spill*)
(RApass unparse-L15b assign-frame! spill*))) (RApass unparse-L15b assign-frame! spill* reg-spillinfo)))
; on entry to loop, have assigned call-live and new-frame variables to frame homes, determined frame sizes, and computed block-entry fp offsets ; on entry to loop, have assigned call-live and new-frame variables to frame homes, determined frame sizes, and computed block-entry fp offsets
(let ([saved-reg-csets (vector-map (lambda (reg) (cset-copy (var-spillable-conflict* reg))) regvec)] (let ([saved-reg-csets (vector-map (lambda (reg) (cset-copy (var-spillable-conflict* reg reg-spillinfo))) regvec)]
[bcache* (map cache-block-info block*)]) [bcache* (map cache-block-info block*)])
(let loop () (let loop ()
(for-each (for-each
(lambda (spill) (lambda (spill)
; remove each spill from each other spillable's spillable conflict set ; remove each spill from each other spillable's spillable conflict set
(unless (uvar-poison? spill) (unless (uvar-poison? spill)
(let ([spill-index (var-index spill)]) (let ([spill-index (var-index spill reg-spillinfo)])
(cset-for-each (var-spillable-conflict* spill) (cset-for-each (var-spillable-conflict* spill reg-spillinfo)
(lambda (i) (lambda (i)
(let ([x (vector-ref varvec i)]) (let ([x (vector-ref varvec i)])
(unless (uvar-location x) (unless (uvar-location x)
(conflict-bit-unset! (var-spillable-conflict* x) spill-index))))))) (conflict-bit-unset! (var-spillable-conflict* x reg-spillinfo) spill-index)))))))
; release the spill's conflict* set ; release the spill's conflict* set
(var-spillable-conflict*-set! spill #f)) (var-spillable-conflict*-set! spill reg-spillinfo #f))
(filter uvar-location spillable*)) (filter uvar-location spillable*))
(set! spillable* (remp uvar-location spillable*)) (set! spillable* (remp uvar-location spillable*))
(let ([saved-move* (map uvar-move* spillable*)]) (let ([saved-move* (map uvar-move* spillable*)])
#;(show-homes) #;(show-homes)
(let ([dummy (RApass unparse-L15c finalize-frame-locations! dummy block*)]) (let ([dummy (RApass unparse-L15c finalize-frame-locations! dummy block*)])
(let ([dummy (RApass unparse-L15d select-instructions! dummy block* live-size (let ([dummy (RApass unparse-L15d select-instructions! dummy block* live-size reg-spillinfo
(let ([libspec (info-lambda-libspec info)]) (let ([libspec (info-lambda-libspec info)])
(and libspec (libspec-does-not-expect-headroom? libspec))))]) (and libspec (libspec-does-not-expect-headroom? libspec))))])
(vector-for-each (lambda (reg) (reg-precolored-set! reg #f)) regvec) (vector-for-each (lambda (reg) (reg-precolored-set! reg reg-spillinfo #f)) regvec)
(let* ([kunspillable (length unspillable*)] [unvarvec (make-vector kunspillable)]) (let* ([kunspillable (length unspillable*)] [unvarvec (make-vector kunspillable)])
; set up var indices & unvarvec mapping from indices to unspillables ; set up var indices & unvarvec mapping from indices to unspillables
(fold-left (lambda (i x) (var-index-set! x i) (vector-set! unvarvec i x) (fx+ i 1)) 0 unspillable*) (fold-left (lambda (i x) (var-index-set! x reg-spillinfo i) (vector-set! unvarvec i x) (fx+ i 1)) 0 unspillable*)
; select-instrcutions! kept intra-block live analysis up-to-date, so now ; select-instrcutions! kept intra-block live analysis up-to-date, so now
; record (reg v spillable v unspillable) x unspillable conflicts ; record (reg v spillable v unspillable) x unspillable conflicts
(RApass unparse-L15d do-unspillable-conflict! kfv kspillable varvec live-size kunspillable unvarvec block*) (RApass unparse-L15d do-unspillable-conflict! kfv kspillable reg-spillinfo varvec live-size kunspillable unvarvec block*)
#;(show-conflicts (info-lambda-name info) varvec unvarvec) #;(show-conflicts (info-lambda-name info) varvec unvarvec reg-spillinfo)
(RApass unparse-L15d assign-registers! info varvec unvarvec) (RApass unparse-L15d assign-registers! info varvec unvarvec reg-spillinfo)
; release the unspillable conflict sets ; release the unspillable conflict sets
(for-each (lambda (x) (var-unspillable-conflict*-set! x #f)) spillable*) (for-each (lambda (x) (var-unspillable-conflict*-set! x reg-spillinfo #f)) spillable*)
(vector-for-each (lambda (x) (var-unspillable-conflict*-set! x #f)) regvec) (vector-for-each (lambda (x) (var-unspillable-conflict*-set! x reg-spillinfo #f)) regvec)
#;(show-homes unspillable*) #;(show-homes unspillable*)
(if (everybody-home?) (if (everybody-home?)
(let ([dummy (RApass unparse-L15e finalize-register-locations! dummy block*)]) (let ([dummy (RApass unparse-L15e finalize-register-locations! dummy block*)])
; release the spillable conflict sets ; release the spillable conflict sets
(vector-for-each (lambda (reg) (var-spillable-conflict*-set! reg #f)) regvec) (vector-for-each (lambda (reg) (var-spillable-conflict*-set! reg reg-spillinfo #f)) regvec)
(do ([i max-fv (fx- i 1)]) ((fx< i 0)) (var-spillable-conflict*-set! (get-fv i) #f)) (do ([i max-fv (fx- i 1)]) ((fx< i 0)) (var-spillable-conflict*-set! (get-fv i) reg-spillinfo #f))
(let-values ([(dummy entry-block* block*) (let-values ([(dummy entry-block* block*)
(xpass expose-overflow-check-blocks! (xpass expose-overflow-check-blocks!
(lambda (val*) (lambda (val*)
@ -10525,11 +10530,12 @@
`(lambda ,info (,entry-block* ...) (,block* ...)))) `(lambda ,info (,entry-block* ...) (,block* ...))))
(begin (begin
(for-each restore-block-info! block* bcache*) (for-each restore-block-info! block* bcache*)
(vector-for-each var-spillable-conflict*-set! regvec saved-reg-csets) (vector-for-each (lambda (r c*) (var-spillable-conflict*-set! r reg-spillinfo c*))
regvec saved-reg-csets)
(for-each (lambda (x) (uvar-location-set! x #f)) spillable*) (for-each (lambda (x) (uvar-location-set! x #f)) spillable*)
(for-each uvar-move*-set! spillable* saved-move*) (for-each uvar-move*-set! spillable* saved-move*)
(set! unspillable* '()) (set! unspillable* '())
(RApass unparse-L15b assign-frame! (filter uvar-spilled? spillable*)) (RApass unparse-L15b assign-frame! (filter uvar-spilled? spillable*) reg-spillinfo)
(loop)))))))))))))))]))) (loop)))))))))))))))])))
; NB: commonize with earlier ; NB: commonize with earlier
@ -10679,7 +10685,6 @@
(set! $np-compile (set! $np-compile
(lambda (original-input-expression pt?) (lambda (original-input-expression pt?)
(with-initialized-registers
(fluid-let ([frame-vars (make-vector 8 #f)] (fluid-let ([frame-vars (make-vector 8 #f)]
[next-lambda-seqno 0] [next-lambda-seqno 0]
[pass-time? pass-time?]) [pass-time? pass-time?])
@ -10722,11 +10727,10 @@
(pass np-flatten-case-lambda unparse-L12) (pass np-flatten-case-lambda unparse-L12)
(pass np-insert-trap-check unparse-L12.5) (pass np-insert-trap-check unparse-L12.5)
(pass np-impose-calling-conventions unparse-L13) (pass np-impose-calling-conventions unparse-L13)
np-after-calling-conventions))))) np-after-calling-conventions))))
(set! $np-boot-code (set! $np-boot-code
(lambda (which) (lambda (which)
(with-initialized-registers
($c-func-code-record ($c-func-code-record
(fluid-let ([frame-vars (make-vector 8 #f)] (fluid-let ([frame-vars (make-vector 8 #f)]
[next-lambda-seqno 0] [next-lambda-seqno 0]
@ -10735,7 +10739,7 @@
(np-after-calling-conventions (np-after-calling-conventions
(with-output-language (L13 Program) (with-output-language (L13 Program)
(let ([l (make-local-label 'Linvoke)]) (let ([l (make-local-label 'Linvoke)])
`(labels ([,l (hand-coded ,which)]) ,l)))))))))) `(labels ([,l (hand-coded ,which)]) ,l)))))))))
) )
(set! $np-tracer tracer) (set! $np-tracer tracer)

35
racket/src/ChezScheme/s/np-info.ss
View File

@ -95,38 +95,33 @@
((new kill*) libspec save-ra?)])))) ((new kill*) libspec save-ra?)]))))
(module (intrinsic-info-asmlib intrinsic-return-live* intrinsic-entry-live* intrinsic-modify-reg* dorest-intrinsics) (module (intrinsic-info-asmlib intrinsic-return-live* intrinsic-entry-live* intrinsic-modify-reg* dorest-intrinsics)
; standing on our heads here to avoid referencing registers at
; load time...would be cleaner if registers were immutable,
; i.e., mutable fields (direct and inherited from var) were kept
; in separate tables...but that might add more cost to register
; allocation, which is already expensive.
(define-record-type intrinsic (define-record-type intrinsic
(nongenerative #{intrinsic bcpkdd2y9yyv643zicd4jbe3y-8}) (nongenerative #{intrinsic bcpkdd2y9yyv643zicd4jbe3y-A})
(sealed #t) (sealed #t)
(fields libspec get-kill* get-live* get-rv*)) (fields libspec kill* live* rv*))
(define intrinsic-info-asmlib (define intrinsic-info-asmlib
(lambda (intrinsic save-ra?) (lambda (intrinsic save-ra?)
(make-info-asmlib ((intrinsic-get-kill* intrinsic)) (make-info-asmlib (intrinsic-kill* intrinsic)
(intrinsic-libspec intrinsic) (intrinsic-libspec intrinsic)
save-ra? save-ra?
((intrinsic-get-live* intrinsic))))) (intrinsic-live* intrinsic))))
(define intrinsic-return-live* (define intrinsic-return-live*
; used a handful of times, just while compiling library.ss...don't bother optimizing ; used a handful of times, just while compiling library.ss...don't bother optimizing
(lambda (intrinsic) (lambda (intrinsic)
(fold-left (lambda (live* kill) (remq kill live*)) (fold-left (lambda (live* kill) (remq kill live*))
(vector->list regvec) ((intrinsic-get-kill* intrinsic))))) (vector->list regvec) (intrinsic-kill* intrinsic))))
(define intrinsic-entry-live* (define intrinsic-entry-live*
; used a handful of times, just while compiling library.ss...don't bother optimizing ; used a handful of times, just while compiling library.ss...don't bother optimizing
(lambda (intrinsic) ; return-live* - rv + live* (lambda (intrinsic) ; return-live* - rv + live*
(fold-left (lambda (live* live) (if (memq live live*) live* (cons live live*))) (fold-left (lambda (live* live) (if (memq live live*) live* (cons live live*)))
(fold-left (lambda (live* rv) (remq rv live*)) (fold-left (lambda (live* rv) (remq rv live*))
(intrinsic-return-live* intrinsic) (intrinsic-return-live* intrinsic)
((intrinsic-get-rv* intrinsic))) (intrinsic-rv* intrinsic))
((intrinsic-get-live* intrinsic))))) (intrinsic-live* intrinsic))))
(define intrinsic-modify-reg* (define intrinsic-modify-reg*
(lambda (intrinsic) (lambda (intrinsic)
(append ((intrinsic-get-rv* intrinsic)) (append (intrinsic-rv* intrinsic)
((intrinsic-get-kill* intrinsic))))) (intrinsic-kill* intrinsic))))
(define-syntax declare-intrinsic (define-syntax declare-intrinsic
(syntax-rules (unquote) (syntax-rules (unquote)
[(_ name entry-name (kill ...) (live ...) (rv ...)) [(_ name entry-name (kill ...) (live ...) (rv ...))
@ -134,9 +129,9 @@
(define name (define name
(make-intrinsic (make-intrinsic
(lookup-libspec entry-name) (lookup-libspec entry-name)
(lambda () (reg-list kill ...)) (reg-list kill ...)
(lambda () (reg-list live ...)) (reg-list live ...)
(lambda () (reg-list rv ...)))) (reg-list rv ...)))
(export name))])) (export name))]))
; must include in kill ... any register explicitly assigned by the intrinsic ; must include in kill ... any register explicitly assigned by the intrinsic
; plus additional registers as needed to avoid spilled unspillables. the ; plus additional registers as needed to avoid spilled unspillables. the
@ -183,9 +178,9 @@
'() '()
(cons #`(make-intrinsic (cons #`(make-intrinsic
(lookup-libspec #,(construct-name #'k "dorest" i)) (lookup-libspec #,(construct-name #'k "dorest" i))
(lambda () (reg-list %ac0 %xp %ts %td)) (reg-list %ac0 %xp %ts %td)
(lambda () (reg-cons* %ac0 (list-xtail arg-registers #,i))) (reg-cons* %ac0 (list-xtail arg-registers #,i))
(lambda () (let ([ls (list-xtail arg-registers #,i)]) (if (null? ls) '() (list (car ls)))))) (let ([ls (list-xtail arg-registers #,i)]) (if (null? ls) '() (list (car ls)))))
(f (fx+ i 1)))))))) (f (fx+ i 1))))))))
dorests))) dorests)))

97
racket/src/ChezScheme/s/np-languages.ss
View File

@ -32,6 +32,7 @@
fv-offset fv-type fv-offset fv-type
var-spillable-conflict* var-spillable-conflict*-set! var-spillable-conflict* var-spillable-conflict*-set!
var-unspillable-conflict* var-unspillable-conflict*-set! var-unspillable-conflict* var-unspillable-conflict*-set!
var-spillinfo-redirect! make-redirect-var
uvar-degree uvar-degree-set! uvar-degree uvar-degree-set!
uvar-info-lambda uvar-info-lambda-set! uvar-info-lambda uvar-info-lambda-set!
uvar-iii uvar-iii-set! uvar-iii uvar-iii-set!
@ -86,14 +87,89 @@
(define datum? (lambda (x) #t)) (define datum? (lambda (x) #t))
(define-record-type var (define-record-type var
(fields (mutable index) (mutable spillable-conflict*) (mutable unspillable-conflict*)) (fields (mutable index-or-redirect) (mutable spillable-conflict*-or-redirect) (mutable unspillable-conflict*-or-redirect))
(nongenerative #{var n93q6qho9id46fha8itaytldd-1}) (nongenerative #{var fjh3mleeyv82pb1x1uhd4vsbv-1})
(protocol (lambda (new) (lambda () (new #f #f #f))))) (protocol (lambda (new) (lambda () (new #f #f #f)))))
;; relies on pairs being distinct from conflict sets and indices:
(define (make-spillinfo-redirect index) (cons index '()))
(define (spillinfo-redirect? v) (pair? v))
(define (spillinfo-redirect-index r) (car r))
(define-record-type precolor-var
(parent var)
(fields (mutable precolored))
(nongenerative #{precolor-var fjh3mleeyv82pb1x1uhd4vsbv-5})
(protocol (lambda (pargs->new) (lambda () ((pargs->new) #f)))))
(define (make-redirect-var name)
(make-precolor-var))
(define (var-spillinfo-redirect! v index)
(let ([r (make-spillinfo-redirect index)])
(var-index-or-redirect-set! v r)
(var-spillable-conflict*-or-redirect-set! v r)
(var-unspillable-conflict*-or-redirect-set! v r)))
(define var-index
(case-lambda
[(v) ; when index is not used for spill information
(safe-assert (not (spillinfo-redirect? (var-index-or-redirect v))))
(var-index-or-redirect v)]
[(v reg-spillinfo) ; when index is used for spill information
(let ([i (var-index-or-redirect v)])
(if (spillinfo-redirect? i)
(var-index-or-redirect
(vector-ref reg-spillinfo (spillinfo-redirect-index i)))
i))]))
(define var-index-set!
(case-lambda
[(v i) ; when index is not used for spill information
(safe-assert (not (spillinfo-redirect? (var-index-or-redirect v))))
(var-index-or-redirect-set! v i)]
[(v reg-spillinfo i) ; when index is used for spill information
(let ([old-i (var-index-or-redirect v)])
(if (spillinfo-redirect? old-i)
(var-index-or-redirect-set!
(vector-ref reg-spillinfo (spillinfo-redirect-index old-i))
i)
(var-index-or-redirect-set! v i)))]))
(define (var-spillable-conflict* v reg-spillinfo)
(let ([c* (var-spillable-conflict*-or-redirect v)])
(if (spillinfo-redirect? c*)
(var-spillable-conflict*-or-redirect
(vector-ref reg-spillinfo (spillinfo-redirect-index c*)))
c*)))
(define (var-unspillable-conflict* v reg-spillinfo)
(let ([c* (var-unspillable-conflict*-or-redirect v)])
(if (spillinfo-redirect? c*)
(var-unspillable-conflict*-or-redirect
(vector-ref reg-spillinfo (spillinfo-redirect-index c*)))
c*)))
(define (var-spillable-conflict*-set! v reg-spillinfo c*)
(let ([old-c* (var-spillable-conflict*-or-redirect v)])
(if (spillinfo-redirect? old-c*)
(var-spillable-conflict*-or-redirect-set!
(vector-ref reg-spillinfo (spillinfo-redirect-index old-c*))
c*)
(var-spillable-conflict*-or-redirect-set! v c*))))
(define (var-unspillable-conflict*-set! v reg-spillinfo c*)
(let ([old-c* (var-unspillable-conflict*-or-redirect v)])
(if (spillinfo-redirect? old-c*)
(var-unspillable-conflict*-or-redirect-set!
(vector-ref reg-spillinfo (spillinfo-redirect-index old-c*))
c*)
(var-unspillable-conflict*-or-redirect-set! v c*))))
(define-record-type (fv $make-fv fv?) (define-record-type (fv $make-fv fv?)
(parent var) (parent var)
(fields offset type) (fields offset type)
(nongenerative #{var n93q6qho9id46fha8itaytldd-2}) (nongenerative #{fv fjh3mleeyv82pb1x1uhd4vsbv-2})
(sealed #t) (sealed #t)
(protocol (protocol
(lambda (pargs->new) (lambda (pargs->new)
@ -107,13 +183,20 @@
(define-record-type reg (define-record-type reg
(parent var) (parent var)
(fields name mdinfo tc-disp callee-save? type (mutable precolored)) (fields name mdinfo tc-disp callee-save? type)
(nongenerative #{var n93q6qho9id46fha8itaytldd-3}) (nongenerative #{reg fjh3mleeyv82pb1x1uhd4vsbv-6})
(sealed #t) (sealed #t)
(protocol (protocol
(lambda (pargs->new) (lambda (pargs->new)
(lambda (name mdinfo tc-disp callee-save? type) (lambda (name mdinfo tc-disp callee-save? type)
((pargs->new) name mdinfo tc-disp callee-save? type #f))))) ((pargs->new) name mdinfo tc-disp callee-save? type)))))
(define (reg-precolored reg reg-spillinfo)
(let ([i (var-index-or-redirect reg)])
(precolor-var-precolored (vector-ref reg-spillinfo (spillinfo-redirect-index i)))))
(define (reg-precolored-set! reg reg-spillinfo v)
(let ([i (var-index-or-redirect reg)])
(precolor-var-precolored-set! (vector-ref reg-spillinfo (spillinfo-redirect-index i)) v)))
(module () (module ()
(record-writer (record-type-descriptor reg) (record-writer (record-type-descriptor reg)
@ -181,7 +264,7 @@
(mutable save-weight) ; must be a fixnum! (mutable save-weight) ; must be a fixnum!
(mutable live-count) ; must be a fixnum! (mutable live-count) ; must be a fixnum!
) )
(nongenerative #{var n93q6qho9id46fha8itaytldd-4}) (nongenerative #{uvar fjh3mleeyv82pb1x1uhd4vsbv-4})
(sealed #t) (sealed #t)
(protocol (protocol
(lambda (pargs->new) (lambda (pargs->new)

50
racket/src/ChezScheme/s/np-register.ss
View File

@ -27,11 +27,15 @@
(module (alias ...) (define x regid) (define alias x) ...)) (module (alias ...) (define x regid) (define alias x) ...))
...)]))) ...)])))
(define-syntax define-register-aliases
(syntax-rules ()
[(_ regid reg-alias ...) (begin (define reg-alias regid) ...)]))
(define-syntax define-allocable-registers (define-syntax define-allocable-registers
(lambda (x) (lambda (x)
(assert (fx<= (constant asm-arg-reg-cnt) (constant asm-arg-reg-max))) (assert (fx<= (constant asm-arg-reg-cnt) (constant asm-arg-reg-max)))
(syntax-case x () (syntax-case x ()
[(_ regvec arg-registers extra-registers extra-fpregisters with-initialized-registers [(_ regvec arg-registers extra-registers extra-fpregisters make-reg-spillinfo
[regid reg-alias ... callee-save? mdinfo type] ...) [regid reg-alias ... callee-save? mdinfo type] ...)
(with-syntax ([((tc-disp ...) (arg-regid ...) (extra-regid ...) (extra-fpregid ...)) (with-syntax ([((tc-disp ...) (arg-regid ...) (extra-regid ...) (extra-fpregid ...))
(syntax-case #'([regid type] ...) (%ac0 %xp %ts %td uptr) (syntax-case #'([regid type] ...) (%ac0 %xp %ts %td uptr)
@ -72,36 +76,20 @@
(f (cdr other*) (cdr other-type*) (cons arg-offset rtc-disp*) (f (cdr other*) (cdr other-type*) (cons arg-offset rtc-disp*)
(fx+ arg-offset (constant ptr-bytes)) fp-offset (cons other rextra*) rfpextra*))))))] (fx+ arg-offset (constant ptr-bytes)) fp-offset (cons other rextra*) rfpextra*))))))]
[_ (syntax-error x "missing or out-of-order required registers")])] [_ (syntax-error x "missing or out-of-order required registers")])]
[(regid-loc ...) (generate-temporaries #'(regid ...))]) [(reg-spillinfo-index ...) (iota (length #'(regid ...)))])
#'(begin #'(begin
(define-syntax define-squawking-parameter (define-once regid (let ([r (make-reg 'regid 'mdinfo tc-disp callee-save? 'type)])
(syntax-rules () (var-spillinfo-redirect! r reg-spillinfo-index)
[(_ (id (... ...)) loc) r))
(begin
(define-once loc (id (... ...)) ($make-thread-parameter #f))
(define-syntax id
(lambda (q)
(unless (identifier? q) (syntax-error q))
#`(let ([x (loc)])
(unless x (syntax-error #'#,q "uninitialized"))
x)))
(... ...))]
[(_ id loc) (define-squawking-parameter (id) loc)]))
(define-squawking-parameter (regid reg-alias ...) regid-loc)
... ...
(define-squawking-parameter regvec regvec-loc) (define-register-aliases regid reg-alias ...) ...
(define-squawking-parameter arg-registers arg-registers-loc) (define regvec (vector regid ...))
(define-squawking-parameter extra-registers extra-registers-loc) (define arg-registers (list arg-regid ...))
(define-squawking-parameter extra-fpregisters extra-fpregisters-loc) (define extra-registers (list extra-regid ...))
(define-syntax with-initialized-registers (define extra-fpregisters (list extra-fpregid ...))
(syntax-rules () (define (make-reg-spillinfo)
[(_ b1 b2 (... ...)) (vector (make-redirect-var 'regid)
(parameterize ([regid-loc (make-reg 'regid 'mdinfo tc-disp callee-save? 'type)] ...) ...))))])))
(parameterize ([regvec-loc (vector regid ...)]
[arg-registers-loc (list arg-regid ...)]
[extra-registers-loc (list extra-regid ...)]
[extra-fpregisters-loc (list extra-fpregid ...)])
(let () b1 b2 (... ...))))]))))])))
(define-syntax define-machine-dependent-registers (define-syntax define-machine-dependent-registers
(lambda (x) (lambda (x)
@ -119,10 +107,10 @@
[(k (reserved [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...) [(k (reserved [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...)
(allocable [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...) (allocable [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...)
(machine-depdendent [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...)) (machine-depdendent [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...))
(with-implicit (k regvec arg-registers extra-registers extra-fpregisters real-register? with-initialized-registers) (with-implicit (k regvec arg-registers extra-registers extra-fpregisters real-register? make-reg-spillinfo)
#`(begin #`(begin
(define-reserved-registers [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...) (define-reserved-registers [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...)
(define-allocable-registers regvec arg-registers extra-registers extra-fpregisters with-initialized-registers (define-allocable-registers regvec arg-registers extra-registers extra-fpregisters make-reg-spillinfo
[areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...) [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...)
(define-machine-dependent-registers [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...) (define-machine-dependent-registers [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...)
(define-syntax real-register? (define-syntax real-register?

22
racket/src/ChezScheme/s/x86_64.ss
View File

@ -2431,11 +2431,11 @@
(module (asm-foreign-call asm-foreign-callable) (module (asm-foreign-call asm-foreign-callable)
(if-feature windows (if-feature windows
(begin (begin
(define make-vint (lambda () (vector %Carg1 %Carg2 %Carg3 %Carg4))) (define vint (vector %Carg1 %Carg2 %Carg3 %Carg4))
(define make-vfp (lambda () (vector %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4)))) (define vfp (vector %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4)))
(begin (begin
(define make-vint (lambda () (vector %Carg1 %Carg2 %Carg3 %Carg4 %Carg5 %Carg6))) (define vint (vector %Carg1 %Carg2 %Carg3 %Carg4 %Carg5 %Carg6))
(define make-vfp (lambda () (vector %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8))))) (define vfp (vector %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8))))
(define (align n size) (define (align n size)
(fxlogand (fx+ n (fx- size 1)) (fx- size))) (fxlogand (fx+ n (fx- size 1)) (fx- size)))
@ -2629,7 +2629,7 @@
`(set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-8 #f) `(set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-8 #f)
,%load ,x ,%zero (immediate ,x-offset)))]))))] ,%load ,x ,%zero (immediate ,x-offset)))]))))]
[load-content-regs [load-content-regs
(lambda (classes size iint ifp vint vfp) (lambda (classes size iint ifp)
(lambda (x) ; requires var (lambda (x) ; requires var
(let loop ([size size] [iint iint] [ifp ifp] [classes classes] [x-offset 0]) (let loop ([size size] [iint iint] [ifp ifp] [classes classes] [x-offset 0])
(cond (cond
@ -2686,7 +2686,7 @@
(add-regs (fx- ints 1) (fx+ ir 1) vr (add-regs (fx- ints 1) (fx+ ir 1) vr
(cons (vector-ref vr ir) regs))]))] (cons (vector-ref vr ir) regs))]))]
[do-args [do-args
(lambda (types vint vfp) (lambda (types)
(if-feature windows (if-feature windows
(let loop ([types types] [locs '()] [regs '()] [fp-regs '()] [i 0] [isp 0]) (let loop ([types types] [locs '()] [regs '()] [fp-regs '()] [i 0] [isp 0])
(if (null? types) (if (null? types)
@ -2721,12 +2721,12 @@
(eq? 'float (caar ($ftd->members ftd)))) (eq? 'float (caar ($ftd->members ftd))))
;; float or double ;; float or double
(loop (cdr types) (loop (cdr types)
(cons (load-content-regs '(sse) ($ftd-size ftd) i i vint vfp) locs) (cons (load-content-regs '(sse) ($ftd-size ftd) i i) locs)
(add-regs 1 i vint regs) (add-regs 1 i vfp fp-regs) (fx+ i 1) isp)] (add-regs 1 i vint regs) (add-regs 1 i vfp fp-regs) (fx+ i 1) isp)]
[else [else
;; integer ;; integer
(loop (cdr types) (loop (cdr types)
(cons (load-content-regs '(integer) ($ftd-size ftd) i i vint vfp) locs) (cons (load-content-regs '(integer) ($ftd-size ftd) i i) locs)
(add-regs 1 i vint regs) fp-regs(fx+ i 1) isp)])] (add-regs 1 i vint regs) fp-regs(fx+ i 1) isp)])]
[else [else
;; pass as value on the stack ;; pass as value on the stack
@ -2790,7 +2790,7 @@
[else [else
;; pass in registers ;; pass in registers
(loop (cdr types) (loop (cdr types)
(cons (load-content-regs classes ($ftd-size ftd) iint ifp vint vfp) locs) (cons (load-content-regs classes ($ftd-size ftd) iint ifp) locs)
(add-regs ints iint vint regs) (add-regs fps ifp vfp fp-regs) (add-regs ints iint vint regs) (add-regs fps ifp vfp fp-regs)
(fx+ iint ints) (fx+ ifp fps) isp)]))] (fx+ iint ints) (fx+ ifp fps) isp)]))]
[else [else
@ -2921,7 +2921,7 @@
[fill-result-here? (result-fits-in-registers? result-classes)] [fill-result-here? (result-fits-in-registers? result-classes)]
[result-reg* (get-result-regs fill-result-here? result-type result-classes)] [result-reg* (get-result-regs fill-result-here? result-type result-classes)]
[adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]) [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)])
(with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*) (make-vint) (make-vfp)) (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*))
(lambda (frame-size nfp locs live* fp-live*) (lambda (frame-size nfp locs live* fp-live*)
(with-values (add-save-fill-target fill-result-here? frame-size locs) (with-values (add-save-fill-target fill-result-here? frame-size locs)
(lambda (frame-size locs) (lambda (frame-size locs)
@ -3065,8 +3065,6 @@
`(set! ,lvalue ,(%inline + ,%sp (immediate ,offset)))))) `(set! ,lvalue ,(%inline + ,%sp (immediate ,offset))))))
(define save-arg-regs (define save-arg-regs
(lambda (types) (lambda (types)
(define vint (make-vint))
(define vfp (make-vfp))
(if-feature windows (if-feature windows
(let f ([types types] [i 0] [isp 8]) (let f ([types types] [i 0] [isp 8])
(if (or (null? types) (fx= i 4)) (if (or (null? types) (fx= i 4))