1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 22:40:34 +02:00

All clauses of function have same nlocals

* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/slot-allocation.scm ($allocation)
  (lookup-nlocals, compute-frame-size, allocate-slots): Adapt to
  have one frame size per function, for all clauses.
This commit is contained in:
Andy Wingo 2017-03-09 14:25:37 +01:00
parent f7909b9516
commit 6d9335ad46
2 changed files with 25 additions and 33 deletions

View file

@ -84,7 +84,7 @@
(define (compile-function cps asm)
(let* ((allocation (allocate-slots cps))
(forwarding-labels (compute-forwarding-labels cps allocation))
(frame-size #f))
(frame-size (lookup-nlocals allocation)))
(define (forward-label k)
(intmap-ref forwarding-labels k (lambda (k) k)))
@ -550,7 +550,6 @@
(unless first?
(emit-end-arity asm))
(emit-label asm label)
(set! frame-size (lookup-nlocals label allocation))
(emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
frame-size alt)
;; All arities define a closure binding in slot 0.

View file

@ -45,7 +45,7 @@
(define-record-type $allocation
(make-allocation slots representations constant-values call-allocs
shuffles frame-sizes)
shuffles frame-size)
allocation?
;; A map of VAR to slot allocation. A slot allocation is an integer,
@ -86,9 +86,12 @@
;;
(shuffles allocation-shuffles)
;; The number of locals for a $kclause.
;; The number of local slots needed for this function. Because we can
;; contify common clause tails, we use one frame size for all clauses
;; to avoid having to adjust the frame size when continuing to labels
;; from other clauses.
;;
(frame-sizes allocation-frame-sizes))
(frame-size allocation-frame-size))
(define-record-type $call-alloc
(make-call-alloc proc-slot slot-map)
@ -135,8 +138,8 @@
(or (call-alloc-slot-map (lookup-call-alloc k allocation))
(error "Call has no slot map" k)))
(define (lookup-nlocals k allocation)
(intmap-ref (allocation-frame-sizes allocation) k))
(define (lookup-nlocals allocation)
(allocation-frame-size allocation))
(define-syntax-rule (persistent-intmap2 exp)
(call-with-values (lambda () exp)
@ -648,7 +651,7 @@ are comparable with eqv?. A tmp slot may be used."
(persistent-intmap
(intmap-fold compute-shuffles cps empty-intmap)))
(define (compute-frame-sizes cps slots call-allocs shuffles)
(define (compute-frame-size cps slots call-allocs shuffles)
;; Minimum frame has one slot: the closure.
(define minimum-frame-size 1)
(define (get-shuffles label)
@ -671,33 +674,23 @@ are comparable with eqv?. A tmp slot may be used."
(define (call-size label nargs size)
(shuffle-size (get-shuffles label)
(max (+ (get-proc-slot label) nargs) size)))
(define (measure-cont label cont frame-sizes clause size)
(define (measure-cont label cont size)
(match cont
(($ $kfun)
(values #f #f #f))
(($ $kclause)
(let ((frame-sizes (if clause
(intmap-add! frame-sizes clause size)
empty-intmap)))
(values frame-sizes label minimum-frame-size)))
(($ $kargs names vars ($ $continue k src exp))
(values frame-sizes clause
(let ((size (max-size* vars size)))
(match exp
(($ $call proc args)
(call-size label (1+ (length args)) size))
(($ $callk _ proc args)
(call-size label (1+ (length args)) size))
(($ $values args)
(shuffle-size (get-shuffles label) size))
(_ size)))))
(let ((size (max-size* vars size)))
(match exp
(($ $call proc args)
(call-size label (1+ (length args)) size))
(($ $callk _ proc args)
(call-size label (1+ (length args)) size))
(($ $values args)
(shuffle-size (get-shuffles label) size))
(_ size))))
(($ $kreceive)
(values frame-sizes clause
(shuffle-size (get-shuffles label) size)))
(($ $ktail)
(values (intmap-add! frame-sizes clause size) #f #f))))
(shuffle-size (get-shuffles label) size))
(_ size)))
(persistent-intmap (intmap-fold measure-cont cps #f #f #f)))
(intmap-fold measure-cont cps minimum-frame-size))
(define (allocate-args cps)
(intmap-fold (lambda (label cont slots)
@ -1043,6 +1036,6 @@ are comparable with eqv?. A tmp slot may be used."
(lambda (slots calls)
(let* ((slots (allocate-lazy-vars cps slots calls live-in lazy))
(shuffles (compute-shuffles cps slots calls live-in))
(frame-sizes (compute-frame-sizes cps slots calls shuffles)))
(frame-size (compute-frame-size cps slots calls shuffles)))
(make-allocation slots representations constants calls
shuffles frame-sizes))))))
shuffles frame-size))))))