mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

SP-relative local addressing

Browse source 
* libguile/vm-engine.c: S24/S12/S8 operands addressed relative to the
  SP, not the FP.  Cache the SP instead of a FP-relative locals
  pointer.  Further cleanups to follow.

* libguile/vm.c (vm_builtin_call_with_values_code): Adapt to mov operand
  addresing change.

* module/language/cps/compile-bytecode.scm (compile-function): Reify
  SP-relative local indexes where appropriate.

* module/system/vm/assembler.scm (emit-fmov*): New helper, exported as
  emit-fmov.
  (shuffling-assembler, define-shuffling-assembler): Rewrite to shuffle
  via push/pop/drop.
  (standard-prelude, opt-prelude, kw-prelude): No need to provide for
  shuffling args.

* test-suite/tests/rtl.test: Update.

* module/language/cps/slot-allocation.scm: Don't reserve slots 253-255.
This commit is contained in:
Andy Wingo 2015-10-21 10:48:58 +02:00
parent 9b1ac02a85
commit 70c317ab51
6 changed files with 562 additions and 549 deletions
Download patch file Download diff file Expand all files Collapse all files

461
libguile/vm-engine.c
View file

File diff suppressed because it is too large Load diff

4
libguile/vm.c
View file

@ -649,9 +649,9 @@ static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = {
static const scm_t_uint32 vm_builtin_call_with_values_code[] = { static const scm_t_uint32 vm_builtin_call_with_values_code[] = {
SCM_PACK_OP_24 (assert_nargs_ee, 3), SCM_PACK_OP_24 (assert_nargs_ee, 3),
SCM_PACK_OP_24 (alloc_frame, 7), SCM_PACK_OP_24 (alloc_frame, 7),
SCM_PACK_OP_12_12 (mov, 6, 1), SCM_PACK_OP_12_12 (mov, 0, 5),
SCM_PACK_OP_24 (call, 6), SCM_PACK_OP_ARG_8_24 (0, 1), SCM_PACK_OP_24 (call, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
SCM_PACK_OP_12_12 (mov, 0, 2), SCM_PACK_OP_24 (long_fmov, 0), SCM_PACK_OP_ARG_8_24 (0, 2),
SCM_PACK_OP_24 (tail_call_shuffle, 7) SCM_PACK_OP_24 (tail_call_shuffle, 7)
}; };

185
module/language/cps/compile-bytecode.scm
View file

@ -100,9 +100,12 @@
(define (constant sym) (define (constant sym)
(lookup-constant-value sym allocation)) (lookup-constant-value sym allocation))
(define (from-sp var)
(- frame-size 1 var))
(define (maybe-mov dst src) (define (maybe-mov dst src)
(unless (= dst src) (unless (= dst src)
(emit-mov asm dst src))) (emit-mov asm (from-sp dst) (from-sp src))))
(define (compile-tail label exp) (define (compile-tail label exp)
;; There are only three kinds of expressions in tail position: ;; There are only three kinds of expressions in tail position:
@ -110,12 +113,12 @@
(match exp (match exp
(($ $call proc args) (($ $call proc args)
(for-each (match-lambda (for-each (match-lambda
((src . dst) (emit-mov asm dst src))) ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation)) (lookup-parallel-moves label allocation))
(emit-tail-call asm (1+ (length args)))) (emit-tail-call asm (1+ (length args))))
(($ $callk k proc args) (($ $callk k proc args)
(for-each (match-lambda (for-each (match-lambda
((src . dst) (emit-mov asm dst src))) ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation)) (lookup-parallel-moves label allocation))
(emit-tail-call-label asm (1+ (length args)) k)) (emit-tail-call-label asm (1+ (length args)) k))
(($ $values ()) (($ $values ())
@ -123,83 +126,109 @@
(emit-return-values asm)) (emit-return-values asm))
(($ $values (arg)) (($ $values (arg))
(if (maybe-slot arg) (if (maybe-slot arg)
(emit-return asm (slot arg)) (emit-return asm (from-sp (slot arg)))
(begin (begin
(emit-load-constant asm 1 (constant arg)) (when (< frame-size 2)
(emit-return asm 1)))) (emit-alloc-frame asm 2))
(emit-load-constant asm (from-sp 1) (constant arg))
(emit-return asm (from-sp 1)))))
(($ $values args) (($ $values args)
(for-each (match-lambda (for-each (match-lambda
((src . dst) (emit-mov asm dst src))) ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation)) (lookup-parallel-moves label allocation))
(emit-reset-frame asm (1+ (length args))) (emit-reset-frame asm (1+ (length args)))
(emit-return-values asm)) (emit-return-values asm))
(($ $primcall 'return (arg)) (($ $primcall 'return (arg))
(emit-return asm (slot arg))))) (emit-return asm (from-sp (slot arg))))))
(define (compile-value label exp dst) (define (compile-value label exp dst)
(match exp (match exp
(($ $values (arg)) (($ $values (arg))
(maybe-mov dst (slot arg))) (maybe-mov dst (slot arg)))
(($ $const exp) (($ $const exp)
(emit-load-constant asm dst exp)) (emit-load-constant asm (from-sp dst) exp))
(($ $closure k 0) (($ $closure k 0)
(emit-load-static-procedure asm dst k)) (emit-load-static-procedure asm (from-sp dst) k))
(($ $closure k nfree) (($ $closure k nfree)
(emit-make-closure asm dst k nfree)) (emit-make-closure asm (from-sp dst) k nfree))
(($ $primcall 'current-module) (($ $primcall 'current-module)
(emit-current-module asm dst)) (emit-current-module asm (from-sp dst)))
(($ $primcall 'cached-toplevel-box (scope name bound?)) (($ $primcall 'cached-toplevel-box (scope name bound?))
(emit-cached-toplevel-box asm dst (constant scope) (constant name) (emit-cached-toplevel-box asm (from-sp dst)
(constant scope) (constant name)
(constant bound?))) (constant bound?)))
(($ $primcall 'cached-module-box (mod name public? bound?)) (($ $primcall 'cached-module-box (mod name public? bound?))
(emit-cached-module-box asm dst (constant mod) (constant name) (emit-cached-module-box asm (from-sp dst)
(constant mod) (constant name)
(constant public?) (constant bound?))) (constant public?) (constant bound?)))
(($ $primcall 'resolve (name bound?)) (($ $primcall 'resolve (name bound?))
(emit-resolve asm dst (constant bound?) (slot name))) (emit-resolve asm (from-sp dst) (constant bound?)
(from-sp (slot name))))
(($ $primcall 'free-ref (closure idx)) (($ $primcall 'free-ref (closure idx))
(emit-free-ref asm dst (slot closure) (constant idx))) (emit-free-ref asm (from-sp dst) (from-sp (slot closure))
(constant idx)))
(($ $primcall 'vector-ref (vector index)) (($ $primcall 'vector-ref (vector index))
(emit-vector-ref asm dst (slot vector) (slot index))) (emit-vector-ref asm (from-sp dst) (from-sp (slot vector))
(from-sp (slot index))))
(($ $primcall 'make-vector (length init)) (($ $primcall 'make-vector (length init))
(emit-make-vector asm dst (slot length) (slot init))) (emit-make-vector asm (from-sp dst) (from-sp (slot length))
(from-sp (slot init))))
(($ $primcall 'make-vector/immediate (length init)) (($ $primcall 'make-vector/immediate (length init))
(emit-make-vector/immediate asm dst (constant length) (slot init))) (emit-make-vector/immediate asm (from-sp dst) (constant length)
(from-sp (slot init))))
(($ $primcall 'vector-ref/immediate (vector index)) (($ $primcall 'vector-ref/immediate (vector index))
(emit-vector-ref/immediate asm dst (slot vector) (constant index))) (emit-vector-ref/immediate asm (from-sp dst) (from-sp (slot vector))
(constant index)))
(($ $primcall 'allocate-struct (vtable nfields)) (($ $primcall 'allocate-struct (vtable nfields))
(emit-allocate-struct asm dst (slot vtable) (slot nfields))) (emit-allocate-struct asm (from-sp dst) (from-sp (slot vtable))
(from-sp (slot nfields))))
(($ $primcall 'allocate-struct/immediate (vtable nfields)) (($ $primcall 'allocate-struct/immediate (vtable nfields))
(emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields))) (emit-allocate-struct/immediate asm (from-sp dst)
(from-sp (slot vtable))
(constant nfields)))
(($ $primcall 'struct-ref (struct n)) (($ $primcall 'struct-ref (struct n))
(emit-struct-ref asm dst (slot struct) (slot n))) (emit-struct-ref asm (from-sp dst) (from-sp (slot struct))
(from-sp (slot n))))
(($ $primcall 'struct-ref/immediate (struct n)) (($ $primcall 'struct-ref/immediate (struct n))
(emit-struct-ref/immediate asm dst (slot struct) (constant n))) (emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct))
(constant n)))
(($ $primcall 'builtin-ref (name)) (($ $primcall 'builtin-ref (name))
(emit-builtin-ref asm dst (constant name))) (emit-builtin-ref asm (from-sp dst) (constant name)))
(($ $primcall 'bv-u8-ref (bv idx)) (($ $primcall 'bv-u8-ref (bv idx))
(emit-bv-u8-ref asm dst (slot bv) (slot idx))) (emit-bv-u8-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-s8-ref (bv idx)) (($ $primcall 'bv-s8-ref (bv idx))
(emit-bv-s8-ref asm dst (slot bv) (slot idx))) (emit-bv-s8-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-u16-ref (bv idx)) (($ $primcall 'bv-u16-ref (bv idx))
(emit-bv-u16-ref asm dst (slot bv) (slot idx))) (emit-bv-u16-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-s16-ref (bv idx)) (($ $primcall 'bv-s16-ref (bv idx))
(emit-bv-s16-ref asm dst (slot bv) (slot idx))) (emit-bv-s16-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-u32-ref (bv idx val)) (($ $primcall 'bv-u32-ref (bv idx val))
(emit-bv-u32-ref asm dst (slot bv) (slot idx))) (emit-bv-u32-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-s32-ref (bv idx val)) (($ $primcall 'bv-s32-ref (bv idx val))
(emit-bv-s32-ref asm dst (slot bv) (slot idx))) (emit-bv-s32-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-u64-ref (bv idx val)) (($ $primcall 'bv-u64-ref (bv idx val))
(emit-bv-u64-ref asm dst (slot bv) (slot idx))) (emit-bv-u64-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-s64-ref (bv idx val)) (($ $primcall 'bv-s64-ref (bv idx val))
(emit-bv-s64-ref asm dst (slot bv) (slot idx))) (emit-bv-s64-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-f32-ref (bv idx val)) (($ $primcall 'bv-f32-ref (bv idx val))
(emit-bv-f32-ref asm dst (slot bv) (slot idx))) (emit-bv-f32-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-f64-ref (bv idx val)) (($ $primcall 'bv-f64-ref (bv idx val))
(emit-bv-f64-ref asm dst (slot bv) (slot idx))) (emit-bv-f64-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall name args) (($ $primcall name args)
;; FIXME: Inline all the cases. ;; FIXME: Inline all the cases.
(let ((inst (prim-instruction name))) (let ((inst (prim-instruction name)))
(emit-text asm `((,inst ,dst ,@(map slot args)))))))) (emit-text asm `((,inst ,(from-sp dst)
,@(map (compose from-sp slot) args))))))))
(define (compile-effect label exp k) (define (compile-effect label exp k)
(match exp (match exp
@ -210,7 +239,8 @@
(let ((receive-args (gensym "handler")) (let ((receive-args (gensym "handler"))
(nreq (length req)) (nreq (length req))
(proc-slot (lookup-call-proc-slot label allocation))) (proc-slot (lookup-call-proc-slot label allocation)))
(emit-prompt asm (slot tag) escape? proc-slot receive-args) (emit-prompt asm (from-sp (slot tag)) escape? proc-slot
receive-args)
(emit-br asm k) (emit-br asm k)
(emit-label asm receive-args) (emit-label asm receive-args)
(unless (and rest (zero? nreq)) (unless (and rest (zero? nreq))
@ -221,57 +251,71 @@
(maybe-slot rest)))) (maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq))) (emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda (for-each (match-lambda
((src . dst) (emit-mov asm dst src))) ((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves handler allocation)) (lookup-parallel-moves handler allocation))
(emit-reset-frame asm frame-size) (emit-reset-frame asm frame-size)
(emit-br asm (forward-label khandler-body)))))) (emit-br asm (forward-label khandler-body))))))
(($ $primcall 'cache-current-module! (sym scope)) (($ $primcall 'cache-current-module! (sym scope))
(emit-cache-current-module! asm (slot sym) (constant scope))) (emit-cache-current-module! asm (from-sp (slot sym)) (constant scope)))
(($ $primcall 'free-set! (closure idx value)) (($ $primcall 'free-set! (closure idx value))
(emit-free-set! asm (slot closure) (slot value) (constant idx))) (emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
(constant idx)))
(($ $primcall 'box-set! (box value)) (($ $primcall 'box-set! (box value))
(emit-box-set! asm (slot box) (slot value))) (emit-box-set! asm (from-sp (slot box)) (from-sp (slot value))))
(($ $primcall 'struct-set! (struct index value)) (($ $primcall 'struct-set! (struct index value))
(emit-struct-set! asm (slot struct) (slot index) (slot value))) (emit-struct-set! asm (from-sp (slot struct)) (from-sp (slot index))
(from-sp (slot value))))
(($ $primcall 'struct-set!/immediate (struct index value)) (($ $primcall 'struct-set!/immediate (struct index value))
(emit-struct-set!/immediate asm (slot struct) (constant index) (slot value))) (emit-struct-set!/immediate asm (from-sp (slot struct))
(constant index) (from-sp (slot value))))
(($ $primcall 'vector-set! (vector index value)) (($ $primcall 'vector-set! (vector index value))
(emit-vector-set! asm (slot vector) (slot index) (slot value))) (emit-vector-set! asm (from-sp (slot vector)) (from-sp (slot index))
(from-sp (slot value))))
(($ $primcall 'vector-set!/immediate (vector index value)) (($ $primcall 'vector-set!/immediate (vector index value))
(emit-vector-set!/immediate asm (slot vector) (constant index) (emit-vector-set!/immediate asm (from-sp (slot vector))
(slot value))) (constant index) (from-sp (slot value))))
(($ $primcall 'set-car! (pair value)) (($ $primcall 'set-car! (pair value))
(emit-set-car! asm (slot pair) (slot value))) (emit-set-car! asm (from-sp (slot pair)) (from-sp (slot value))))
(($ $primcall 'set-cdr! (pair value)) (($ $primcall 'set-cdr! (pair value))
(emit-set-cdr! asm (slot pair) (slot value))) (emit-set-cdr! asm (from-sp (slot pair)) (from-sp (slot value))))
(($ $primcall 'define! (sym value)) (($ $primcall 'define! (sym value))
(emit-define! asm (slot sym) (slot value))) (emit-define! asm (from-sp (slot sym)) (from-sp (slot value))))
(($ $primcall 'push-fluid (fluid val)) (($ $primcall 'push-fluid (fluid val))
(emit-push-fluid asm (slot fluid) (slot val))) (emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val))))
(($ $primcall 'pop-fluid ()) (($ $primcall 'pop-fluid ())
(emit-pop-fluid asm)) (emit-pop-fluid asm))
(($ $primcall 'wind (winder unwinder)) (($ $primcall 'wind (winder unwinder))
(emit-wind asm (slot winder) (slot unwinder))) (emit-wind asm (from-sp (slot winder)) (from-sp (slot unwinder))))
(($ $primcall 'bv-u8-set! (bv idx val)) (($ $primcall 'bv-u8-set! (bv idx val))
(emit-bv-u8-set! asm (slot bv) (slot idx) (slot val))) (emit-bv-u8-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-s8-set! (bv idx val)) (($ $primcall 'bv-s8-set! (bv idx val))
(emit-bv-s8-set! asm (slot bv) (slot idx) (slot val))) (emit-bv-s8-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-u16-set! (bv idx val)) (($ $primcall 'bv-u16-set! (bv idx val))
(emit-bv-u16-set! asm (slot bv) (slot idx) (slot val))) (emit-bv-u16-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-s16-set! (bv idx val)) (($ $primcall 'bv-s16-set! (bv idx val))
(emit-bv-s16-set! asm (slot bv) (slot idx) (slot val))) (emit-bv-s16-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-u32-set! (bv idx val)) (($ $primcall 'bv-u32-set! (bv idx val))
(emit-bv-u32-set! asm (slot bv) (slot idx) (slot val))) (emit-bv-u32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-s32-set! (bv idx val)) (($ $primcall 'bv-s32-set! (bv idx val))
(emit-bv-s32-set! asm (slot bv) (slot idx) (slot val))) (emit-bv-s32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-u64-set! (bv idx val)) (($ $primcall 'bv-u64-set! (bv idx val))
(emit-bv-u64-set! asm (slot bv) (slot idx) (slot val))) (emit-bv-u64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-s64-set! (bv idx val)) (($ $primcall 'bv-s64-set! (bv idx val))
(emit-bv-s64-set! asm (slot bv) (slot idx) (slot val))) (emit-bv-s64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-f32-set! (bv idx val)) (($ $primcall 'bv-f32-set! (bv idx val))
(emit-bv-f32-set! asm (slot bv) (slot idx) (slot val))) (emit-bv-f32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-f64-set! (bv idx val)) (($ $primcall 'bv-f64-set! (bv idx val))
(emit-bv-f64-set! asm (slot bv) (slot idx) (slot val))) (emit-bv-f64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'unwind ()) (($ $primcall 'unwind ())
(emit-unwind asm)))) (emit-unwind asm))))
@ -279,7 +323,7 @@
(match exp (match exp
(($ $values args) (($ $values args)
(for-each (match-lambda (for-each (match-lambda
((src . dst) (emit-mov asm dst src))) ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))))) (lookup-parallel-moves label allocation)))))
(define (compile-test label exp kt kf next-label) (define (compile-test label exp kt kf next-label)
@ -294,22 +338,23 @@
(define (unary op sym) (define (unary op sym)
(cond (cond
((eq? kt next-label) ((eq? kt next-label)
(op asm (slot sym) #t kf)) (op asm (from-sp (slot sym)) #t kf))
((eq? kf next-label) ((eq? kf next-label)
(op asm (slot sym) #f kt)) (op asm (from-sp (slot sym)) #f kt))
(else (else
(let ((invert? (not (prefer-true?)))) (let ((invert? (not (prefer-true?))))
(op asm (slot sym) invert? (if invert? kf kt)) (op asm (from-sp (slot sym)) invert? (if invert? kf kt))
(emit-br asm (if invert? kt kf)))))) (emit-br asm (if invert? kt kf))))))
(define (binary op a b) (define (binary op a b)
(cond (cond
((eq? kt next-label) ((eq? kt next-label)
(op asm (slot a) (slot b) #t kf)) (op asm (from-sp (slot a)) (from-sp (slot b)) #t kf))
((eq? kf next-label) ((eq? kf next-label)
(op asm (slot a) (slot b) #f kt)) (op asm (from-sp (slot a)) (from-sp (slot b)) #f kt))
(else (else
(let ((invert? (not (prefer-true?)))) (let ((invert? (not (prefer-true?))))
(op asm (slot a) (slot b) invert? (if invert? kf kt)) (op asm (from-sp (slot a)) (from-sp (slot b)) invert?
(if invert? kf kt))
(emit-br asm (if invert? kt kf)))))) (emit-br asm (if invert? kt kf))))))
(match exp (match exp
(($ $values (sym)) (unary emit-br-if-true sym)) (($ $values (sym)) (unary emit-br-if-true sym))
@ -344,7 +389,7 @@
(nargs (1+ (length args))) (nargs (1+ (length args)))
(arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs)))) (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
(for-each (match-lambda (for-each (match-lambda
((src . dst) (emit-mov asm dst src))) ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation)) (lookup-parallel-moves label allocation))
(emit-call asm proc-slot nargs) (emit-call asm proc-slot nargs)
(emit-dead-slot-map asm proc-slot (emit-dead-slot-map asm proc-slot
@ -365,7 +410,7 @@
(when (and rest-var (maybe-slot rest-var)) (when (and rest-var (maybe-slot rest-var))
(emit-bind-rest asm (+ proc-slot 1 nreq))) (emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda (for-each (match-lambda
((src . dst) (emit-mov asm dst src))) ((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves k allocation)) (lookup-parallel-moves k allocation))
(emit-reset-frame asm frame-size))))) (emit-reset-frame asm frame-size)))))
(match exp (match exp

23
module/language/cps/slot-allocation.scm
View file

@ -537,12 +537,6 @@ are comparable with eqv?. A tmp slot may be used."
;; could be that they are out of the computed live set. In that case ;; could be that they are out of the computed live set. In that case
;; they need to be adjoined to the live set, used when choosing a ;; they need to be adjoined to the live set, used when choosing a
;; temporary slot. ;; temporary slot.
;;
;; Note that although we reserve slots 253-255 for shuffling operands
;; that address less than the full 24-bit range of locals, that
;; reservation doesn't apply here, because this temporary itself is
;; used while doing parallel assignment via "mov", and "mov" does not
;; need shuffling.
(define (compute-tmp-slot live stack-slots) (define (compute-tmp-slot live stack-slots)
(find-first-zero (fold add-live-slot live stack-slots))) (find-first-zero (fold add-live-slot live stack-slots)))
@ -687,10 +681,9 @@ are comparable with eqv?. A tmp slot may be used."
(match vars (match vars
(() slots) (() slots)
((var . vars) ((var . vars)
(let ((n (if (<= 253 n 255) 256 n))) (lp vars
(lp vars (intmap-add! slots var n)
(intmap-add! slots var n) (1+ n))))))))
(1+ n)))))))))
(_ slots))) (_ slots)))
cps empty-intmap)) cps empty-intmap))
@ -701,15 +694,9 @@ are comparable with eqv?. A tmp slot may be used."
(logand live-slots (lognot (ash 1 slot)))) (logand live-slots (lognot (ash 1 slot))))
(define-inlinable (compute-slot live-slots hint) (define-inlinable (compute-slot live-slots hint)
;; Slots 253-255 are reserved for shuffling; see comments in (if (and hint (not (logbit? hint live-slots)))
;; assembler.scm.
(if (and hint (not (logbit? hint live-slots))
(or (< hint 253) (> hint 255)))
hint hint
(let ((slot (find-first-zero live-slots))) (find-first-zero live-slots)))
(if (or (< slot 253) (> slot 255))
slot
(+ 256 (find-first-zero (ash live-slots -256)))))))
(define (allocate-lazy-vars cps slots call-allocs live-in lazy) (define (allocate-lazy-vars cps slots call-allocs live-in lazy)
(define (compute-live-slots slots label) (define (compute-live-slots slots label)

324
module/system/vm/assembler.scm
View file

@ -97,6 +97,7 @@
emit-br-if-<= emit-br-if-<=
emit-br-if-logtest emit-br-if-logtest
(emit-mov* . emit-mov) (emit-mov* . emit-mov)
(emit-fmov* . emit-fmov)
(emit-box* . emit-box) (emit-box* . emit-box)
(emit-box-ref* . emit-box-ref) (emit-box-ref* . emit-box-ref)
(emit-box-set!* . emit-box-set!) (emit-box-set!* . emit-box-set!)
@ -638,166 +639,170 @@ later by the linker."
(eval-when (expand) (eval-when (expand)
;; Some operands are encoded using a restricted subset of the full ;; In Guile's VM, locals are usually addressed via the stack pointer
;; 24-bit local address space, in order to make the bytecode more ;; (SP). There can be up to 2^24 slots for local variables in a
;; dense in the usual case that there are few live locals. Here we ;; frame. Some instructions encode their operands using a restricted
;; define wrapper emitters that shuffle out-of-range operands into and ;; subset of the full 24-bit local address space, in order to make the
;; out of the reserved range of locals [233,255]. This range is ;; bytecode more dense in the usual case that a function needs few
;; sufficient because these restricted operands are only present in ;; local slots. To allow these instructions to be used when there are
;; the first word of an instruction. Since 8 bits is the smallest ;; many local slots, we can temporarily push the values on the stack,
;; slot-addressing operand size, that means we can fit 3 operands in ;; operate on them there, and then store back any result as we pop the
;; the 24 bits of payload of the first word (the lower 8 bits being ;; SP to its original position.
;; taken by the opcode).
;; ;;
;; The result are wrapper emitters with the same arity, ;; We implement this shuffling via wrapper emitters that have the same
;; e.g. emit-cons* that wraps emit-cons. We expose these wrappers as ;; arity as the emitter they wrap, e.g. emit-cons* that wraps
;; the public interface for emitting `cons' instructions. That way we ;; emit-cons. We expose these wrappers as the public interface for
;; solve the problem fully and in just one place. The only manual ;; emitting `cons' instructions. That way we solve the problem fully
;; care that need be taken is in the exports list at the top of the ;; and in just one place. The only manual care that need be taken is
;; file -- to be sure that we export the wrapper and not the wrapped ;; in the exports list at the top of the file -- to be sure that we
;; emitter. ;; export the wrapper and not the wrapped emitter.
(define (shuffling-assembler name kind word0 word*) (define (shuffling-assembler emit kind word0 word*)
(define (analyze-first-word) (with-syntax ((emit emit))
(define-syntax op-case (match (cons* word0 kind word*)
(syntax-rules () (('X8_S12_S12 '!)
((_ type ((%type %kind arg ...) values) clause ...) #'(lambda (asm a b)
(if (and (eq? type '%type) (eq? kind '%kind)) (cond
(with-syntax (((arg ...) (generate-temporaries #'(arg ...)))) ((< (logior a b) (ash 1 12))
#'((arg ...) values)) (emit asm a b))
(op-case type clause ...))) (else
((_ type) (emit-push asm a)
#f))) (emit-push asm (1+ b))
(op-case (emit asm 1 0)
word0 (emit-drop asm 2)))))
((X8_S8_I16 <- a imm) (('X8_S12_S12 '<-)
(values (if (< a (ash 1 8)) a 253) #'(lambda (asm dst a)
imm)) (cond
((X8_S12_S12 ! a b) ((< (logior dst a) (ash 1 12))
(values (if (< a (ash 1 12)) a (begin (emit-mov* asm 253 a) 253)) (emit asm dst a))
(if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254)))) (else
((X8_S12_S12 <- a b) (emit-push asm a)
(values (if (< a (ash 1 12)) a 253) (emit asm 0 0)
(if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254)))) (emit-pop asm dst)))))
((X8_S12_C12 <- a b)
(values (if (< a (ash 1 12)) a 253)
b))
((X8_S8_S8_S8 ! a b c) (('X8_S12_S12 '! 'X8_C24)
(values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) #'(lambda (asm a b c)
(if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) (cond
(if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))) ((< (logior a b) (ash 1 12))
((X8_S8_S8_S8 <- a b c) (emit asm a b c))
(values (if (< a (ash 1 8)) a 253) (else
(if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) (emit-push asm a)
(if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))) (emit-push asm (1+ b))
(emit asm 1 0 c)
(emit-drop asm 2)))))
(('X8_S12_S12 '<- 'X8_C24)
#'(lambda (asm dst a c)
(cond
((< (logior dst a) (ash 1 12))
(emit asm dst a c))
(else
(emit-push asm a)
(emit asm 0 0 c)
(emit-pop asm dst)))))
((X8_S8_S8_C8 ! a b c) (('X8_S12_C12 '<-)
(values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) #'(lambda (asm dst const)
(if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) (cond
c)) ((< dst (ash 1 12))
((X8_S8_S8_C8 <- a b c) (emit asm dst const))
(values (if (< a (ash 1 8)) a 253) (else
(if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) ;; Push garbage value to make space for dst.
c)) (emit-push asm dst)
(emit asm 0 const)
(emit-pop asm dst)))))
((X8_S8_C8_S8 ! a b c) (('X8_S8_I16 '<-)
(values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) #'(lambda (asm dst imm)
b (cond
(if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))) ((< dst (ash 1 8))
((X8_S8_C8_S8 <- a b c) (emit asm dst imm))
(values (if (< a (ash 1 8)) a 253) (else
b ;; Push garbage value to make space for dst.
(if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))))) (emit-push asm dst)
(emit asm 0 imm)
(emit-pop asm dst)))))
(define (tail-formals type) (('X8_S8_S8_S8 '!)
(define-syntax op-case #'(lambda (asm a b c)
(syntax-rules () (cond
((op-case type (%type arg ...) clause ...) ((< (logior a b c) (ash 1 8))
(if (eq? type '%type) (emit asm a b c))
(generate-temporaries #'(arg ...)) (else
(op-case type clause ...))) (emit-push asm a)
((op-case type) (emit-push asm (+ b 1))
(error "unmatched type" type)))) (emit-push asm (+ c 2))
(op-case type (emit asm 2 1 0)
(C32 a) (emit-drop asm 3)))))
(I32 imm) (('X8_S8_S8_S8 '<-)
(A32 imm) #'(lambda (asm dst a b)
(B32) (cond
(N32 label) ((< (logior dst a b) (ash 1 8))
(R32 label) (emit asm dst a b))
(L32 label) (else
(LO32 label offset) (emit-push asm a)
(C8_C24 a b) (emit-push asm (1+ b))
(B1_C7_L24 a b label) (emit asm 1 1 0)
(B1_X7_S24 a b) (emit-drop asm 1)
(B1_X7_F24 a b) (emit-pop asm dst)))))
(B1_X7_C24 a b)
(B1_X7_L24 a label)
(B1_X31 a)
(X8_S24 a)
(X8_F24 a)
(X8_C24 a)
(X8_L24 label)))
(define (shuffle-up dst) (('X8_S8_S8_C8 '<-)
(define-syntax op-case #'(lambda (asm dst a const)
(syntax-rules () (cond
((_ type ((%type ...) exp) clause ...) ((< (logior dst a) (ash 1 8))
(if (memq type '(%type ...)) (emit asm dst a const))
#'exp (else
(op-case type clause ...))) (emit-push asm a)
((_ type) (emit asm 0 0 const)
(error "unexpected type" type)))) (emit-pop asm dst)))))
(with-syntax ((dst dst))
(op-case
word0
((X8_S8_I16 X8_S8_S8_S8 X8_S8_S8_C8 X8_S8_C8_S8)
(unless (< dst (ash 1 8))
(emit-mov* asm dst 253)))
((X8_S12_S12 X8_S12_C12)
(unless (< dst (ash 1 12))
(emit-mov* asm dst 253))))))
(and=> (('X8_S8_C8_S8 '!)
(analyze-first-word) #'(lambda (asm a const b)
(lambda (formals+shuffle) (cond
(with-syntax ((emit-name (id-append name #'emit- name)) ((< (logior a b) (ash 1 8))
(((formal0 ...) shuffle) formals+shuffle) (emit asm a const b))
(((formal* ...) ...) (map tail-formals word*))) (else
(with-syntax (((shuffle-up-dst ...) (emit-push asm a)
(if (eq? kind '<-) (emit-push asm (1+ b))
(syntax-case #'(formal0 ...) () (emit asm 1 const 0)
((dst . _) (emit-drop asm 2)))))
(list (shuffle-up #'dst)))) (('X8_S8_C8_S8 '<-)
'()))) #'(lambda (asm dst const a)
#'(lambda (asm formal0 ... formal* ... ...) (cond
(call-with-values (lambda () shuffle) ((< (logior dst a) (ash 1 8))
(lambda (formal0 ...) (emit asm dst const a))
(emit-name asm formal0 ... formal* ... ...))) (else
shuffle-up-dst ...)))))) (emit-push asm a)
(emit asm 0 const 0)
(emit-pop asm dst))))))))
(define-syntax define-shuffling-assembler (define-syntax define-shuffling-assembler
(lambda (stx) (lambda (stx)
(define (might-shuffle? word0)
(case word0
((X8_S12_S12 X8_S12_C12
X8_S8_I16
X8_S8_S8_S8 X8_S8_S8_C8 X8_S8_C8_S8) #t)
(else #f)))
(syntax-case stx () (syntax-case stx ()
((_ #:except (except ...) name opcode kind word0 word* ...) ((_ #:except (except ...) name opcode kind word0 word* ...)
(cond (let ((_except (syntax->datum #'(except ...)))
((or-map (lambda (op) (eq? (syntax->datum #'name) op)) (_name (syntax->datum #'name))
(map syntax->datum #'(except ...))) (_kind (syntax->datum #'kind))
#'(begin)) (_word0 (syntax->datum #'word0))
((shuffling-assembler #'name (syntax->datum #'kind) (_word* (syntax->datum #'(word* ...)))
(syntax->datum #'word0) (emit (id-append #'name #'emit- #'name)))
(map syntax->datum #'(word* ...))) (cond
=> (lambda (proc) ((and (might-shuffle? _word0) (not (memq _name _except)))
(with-syntax ((emit (id-append #'name (with-syntax
(id-append #'name #'emit- #'name) ((emit* (id-append #'name emit #'*))
#'*)) (proc (shuffling-assembler emit _kind _word0 _word*)))
(proc proc)) #'(define emit*
#'(define emit (let ((emit* proc))
(let ((emit proc)) (hashq-set! assemblers 'name emit*)
(hashq-set! assemblers 'name emit) emit*))))
emit))))) (else
(else #'(begin)))))))) #'(begin)))))))))
(visit-opcodes define-shuffling-assembler #:except (receive mov)) (visit-opcodes define-shuffling-assembler #:except (receive mov))
@ -809,6 +814,9 @@ later by the linker."
(emit-mov asm dst src) (emit-mov asm dst src)
(emit-long-mov asm dst src))) (emit-long-mov asm dst src)))
(define (emit-fmov* asm dst src)
(emit-long-fmov asm dst src))
(define (emit-receive* asm dst proc nlocals) (define (emit-receive* asm dst proc nlocals)
(if (and (< dst (ash 1 12)) (< proc (ash 1 12))) (if (and (< dst (ash 1 12)) (< proc (ash 1 12)))
(emit-receive asm dst proc nlocals) (emit-receive asm dst proc nlocals)
@ -1104,19 +1112,6 @@ returned instead."
(set-arity-definitions! arity (reverse (arity-definitions arity))) (set-arity-definitions! arity (reverse (arity-definitions arity)))
(set-arity-high-pc! arity (asm-start asm)))) (set-arity-high-pc! arity (asm-start asm))))
;; As noted above, we reserve locals 253 through 255 for shuffling large
;; operands. However the calling convention has all arguments passed in
;; a contiguous block. This helper, called after the clause has been
;; chosen and the keyword/optional/rest arguments have been processed,
;; shuffles up arguments from slot 253 and higher into their final
;; allocations.
;;
(define (shuffle-up-args asm nargs)
(when (> nargs 253)
(let ((slot (1- nargs)))
(emit-mov asm (+ slot 3) slot)
(shuffle-up-args asm (1- nargs)))))
(define-macro-assembler (standard-prelude asm nreq nlocals alternate) (define-macro-assembler (standard-prelude asm nreq nlocals alternate)
(cond (cond
(alternate (alternate
@ -1126,8 +1121,7 @@ returned instead."
(emit-assert-nargs-ee/locals asm nreq (- nlocals nreq))) (emit-assert-nargs-ee/locals asm nreq (- nlocals nreq)))
(else (else
(emit-assert-nargs-ee asm nreq) (emit-assert-nargs-ee asm nreq)
(emit-alloc-frame asm nlocals))) (emit-alloc-frame asm nlocals))))
(shuffle-up-args asm nreq))
(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate) (define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
(if alternate (if alternate
@ -1140,8 +1134,7 @@ returned instead."
(emit-br-if-nargs-gt asm (+ nreq nopt) alternate)) (emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
(else (else
(emit-assert-nargs-le asm (+ nreq nopt)))) (emit-assert-nargs-le asm (+ nreq nopt))))
(emit-alloc-frame asm nlocals) (emit-alloc-frame asm nlocals))
(shuffle-up-args asm (+ nreq nopt (if rest? 1 0))))
(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices (define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
allow-other-keys? nlocals alternate) allow-other-keys? nlocals alternate)
@ -1162,8 +1155,7 @@ returned instead."
(+ nreq nopt) (+ nreq nopt)
ntotal ntotal
(intern-constant asm kw-indices)) (intern-constant asm kw-indices))
(emit-alloc-frame asm nlocals) (emit-alloc-frame asm nlocals)))
(shuffle-up-args asm ntotal)))
(define-macro-assembler (label asm sym) (define-macro-assembler (label asm sym)
(hashq-set! (asm-labels asm) sym (asm-start asm))) (hashq-set! (asm-labels asm) sym (asm-start asm)))

114
test-suite/tests/rtl.test
View file

@ -40,8 +40,8 @@ a procedure."
(assemble-program `((begin-program foo (assemble-program `((begin-program foo
((name . foo))) ((name . foo)))
(begin-standard-arity () 2 #f) (begin-standard-arity () 2 #f)
(load-constant 1 ,val) (load-constant 0 ,val)
(return 1) (return 0)
(end-arity) (end-arity)
(end-program)))) (end-program))))
@ -82,15 +82,15 @@ a procedure."
(((assemble-program `((begin-program foo (((assemble-program `((begin-program foo
((name . foo))) ((name . foo)))
(begin-standard-arity () 2 #f) (begin-standard-arity () 2 #f)
(load-static-procedure 1 bar) (load-static-procedure 0 bar)
(return 1) (return 0)
(end-arity) (end-arity)
(end-program) (end-program)
(begin-program bar (begin-program bar
((name . bar))) ((name . bar)))
(begin-standard-arity () 2 #f) (begin-standard-arity () 2 #f)
(load-constant 1 42) (load-constant 0 42)
(return 1) (return 0)
(end-arity) (end-arity)
(end-program))))))) (end-program)))))))
@ -107,16 +107,16 @@ a procedure."
(definition x 1) (definition x 1)
(br fix-body) (br fix-body)
(label loop-head) (label loop-head)
(br-if-= 2 1 #f out) (br-if-= 1 2 #f out)
(add 3 2 3) (add 0 1 0)
(add1 2 2) (add1 1 1)
(br loop-head) (br loop-head)
(label fix-body) (label fix-body)
(load-constant 2 0) (load-constant 1 0)
(load-constant 3 0) (load-constant 0 0)
(br loop-head) (br loop-head)
(label out) (label out)
(return 3) (return 0)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(sumto 1000)))) (sumto 1000))))
@ -133,20 +133,20 @@ a procedure."
(begin-standard-arity () 3 #f) (begin-standard-arity () 3 #f)
(load-constant 1 0) (load-constant 1 0)
(box 1 1) (box 1 1)
(make-closure 2 accum 1) (make-closure 0 accum 1)
(free-set! 2 1 0) (free-set! 0 1 0)
(return 2) (return 0)
(end-arity) (end-arity)
(end-program) (end-program)
(begin-program accum (begin-program accum
((name . accum))) ((name . accum)))
(begin-standard-arity (x) 4 #f) (begin-standard-arity (x) 4 #f)
(definition x 1) (definition x 1)
(free-ref 2 0 0) (free-ref 1 3 0)
(box-ref 3 2) (box-ref 0 1)
(add 3 3 1) (add 0 0 2)
(box-set! 2 3) (box-set! 1 0)
(return 3) (return 0)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(let ((accum (make-accum))) (let ((accum (make-accum)))
@ -162,10 +162,10 @@ a procedure."
((name . call))) ((name . call)))
(begin-standard-arity (f) 7 #f) (begin-standard-arity (f) 7 #f)
(definition f 1) (definition f 1)
(mov 5 1) (mov 1 5)
(call 5 1) (call 5 1)
(receive 2 5 7) (receive 2 5 7)
(return 2) (return 4)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(call (lambda () 42)))) (call (lambda () 42))))
@ -177,11 +177,11 @@ a procedure."
((name . call-with-3))) ((name . call-with-3)))
(begin-standard-arity (f) 7 #f) (begin-standard-arity (f) 7 #f)
(definition f 1) (definition f 1)
(mov 5 1) (mov 1 5)
(load-constant 6 3) (load-constant 0 3)
(call 5 2) (call 5 2)
(receive 2 5 7) (receive 2 5 7)
(return 2) (return 4)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(call-with-3 (lambda (x) (* x 2)))))) (call-with-3 (lambda (x) (* x 2))))))
@ -194,7 +194,7 @@ a procedure."
((name . call))) ((name . call)))
(begin-standard-arity (f) 2 #f) (begin-standard-arity (f) 2 #f)
(definition f 1) (definition f 1)
(mov 0 1) (mov 1 0)
(tail-call 1) (tail-call 1)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
@ -207,8 +207,8 @@ a procedure."
((name . call-with-3))) ((name . call-with-3)))
(begin-standard-arity (f) 2 #f) (begin-standard-arity (f) 2 #f)
(definition f 1) (definition f 1)
(mov 0 1) ;; R0 <- R1 (mov 1 0) ;; R0 <- R1
(load-constant 1 3) ;; R1 <- 3 (load-constant 0 3) ;; R1 <- 3
(tail-call 2) (tail-call 2)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
@ -221,10 +221,10 @@ a procedure."
'((begin-program get-sqrt-trampoline '((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline))) ((name . get-sqrt-trampoline)))
(begin-standard-arity () 2 #f) (begin-standard-arity () 2 #f)
(current-module 1) (current-module 0)
(cache-current-module! 1 sqrt-scope) (cache-current-module! 0 sqrt-scope)
(load-static-procedure 1 sqrt-trampoline) (load-static-procedure 0 sqrt-trampoline)
(return 1) (return 0)
(end-arity) (end-arity)
(end-program) (end-program)
@ -232,8 +232,8 @@ a procedure."
((name . sqrt-trampoline))) ((name . sqrt-trampoline)))
(begin-standard-arity (x) 3 #f) (begin-standard-arity (x) 3 #f)
(definition x 1) (definition x 1)
(cached-toplevel-box 2 sqrt-scope sqrt #t) (cached-toplevel-box 0 sqrt-scope sqrt #t)
(box-ref 0 2) (box-ref 2 0)
(tail-call 2) (tail-call 2)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
@ -249,10 +249,10 @@ a procedure."
'((begin-program make-top-incrementor '((begin-program make-top-incrementor
((name . make-top-incrementor))) ((name . make-top-incrementor)))
(begin-standard-arity () 2 #f) (begin-standard-arity () 2 #f)
(current-module 1) (current-module 0)
(cache-current-module! 1 top-incrementor) (cache-current-module! 0 top-incrementor)
(load-static-procedure 1 top-incrementor) (load-static-procedure 0 top-incrementor)
(return 1) (return 0)
(end-arity) (end-arity)
(end-program) (end-program)
@ -260,9 +260,9 @@ a procedure."
((name . top-incrementor))) ((name . top-incrementor)))
(begin-standard-arity () 3 #f) (begin-standard-arity () 3 #f)
(cached-toplevel-box 1 top-incrementor *top-val* #t) (cached-toplevel-box 1 top-incrementor *top-val* #t)
(box-ref 2 1) (box-ref 0 1)
(add1 2 2) (add1 0 0)
(box-set! 1 2) (box-set! 1 0)
(reset-frame 1) (reset-frame 1)
(return-values) (return-values)
(end-arity) (end-arity)
@ -277,8 +277,8 @@ a procedure."
'((begin-program get-sqrt-trampoline '((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline))) ((name . get-sqrt-trampoline)))
(begin-standard-arity () 2 #f) (begin-standard-arity () 2 #f)
(load-static-procedure 1 sqrt-trampoline) (load-static-procedure 0 sqrt-trampoline)
(return 1) (return 0)
(end-arity) (end-arity)
(end-program) (end-program)
@ -286,8 +286,8 @@ a procedure."
((name . sqrt-trampoline))) ((name . sqrt-trampoline)))
(begin-standard-arity (x) 3 #f) (begin-standard-arity (x) 3 #f)
(definition x 1) (definition x 1)
(cached-module-box 2 (guile) sqrt #t #t) (cached-module-box 0 (guile) sqrt #t #t)
(box-ref 0 2) (box-ref 2 0)
(tail-call 2) (tail-call 2)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
@ -301,8 +301,8 @@ a procedure."
'((begin-program make-top-incrementor '((begin-program make-top-incrementor
((name . make-top-incrementor))) ((name . make-top-incrementor)))
(begin-standard-arity () 2 #f) (begin-standard-arity () 2 #f)
(load-static-procedure 1 top-incrementor) (load-static-procedure 0 top-incrementor)
(return 1) (return 0)
(end-arity) (end-arity)
(end-program) (end-program)
@ -310,10 +310,10 @@ a procedure."
((name . top-incrementor))) ((name . top-incrementor)))
(begin-standard-arity () 3 #f) (begin-standard-arity () 3 #f)
(cached-module-box 1 (tests bytecode) *top-val* #f #t) (cached-module-box 1 (tests bytecode) *top-val* #f #t)
(box-ref 2 1) (box-ref 0 1)
(add1 2 2) (add1 0 0)
(box-set! 1 2) (box-set! 1 0)
(return 2) (return 0)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
((make-top-incrementor)) ((make-top-incrementor))
@ -323,8 +323,8 @@ a procedure."
(let ((return-3 (assemble-program (let ((return-3 (assemble-program
'((begin-program return-3 ((name . return-3))) '((begin-program return-3 ((name . return-3)))
(begin-standard-arity () 2 #f) (begin-standard-arity () 2 #f)
(load-constant 1 3) (load-constant 0 3)
(return 1) (return 0)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(pass-if "program name" (pass-if "program name"
@ -345,8 +345,8 @@ a procedure."
(assemble-program (assemble-program
'((begin-program foo ((name . foo))) '((begin-program foo ((name . foo)))
(begin-standard-arity () 2 #f) (begin-standard-arity () 2 #f)
(load-constant 1 42) (load-constant 0 42)
(return 1) (return 0)
(end-arity) (end-arity)
(end-program)))))) (end-program))))))
@ -356,8 +356,8 @@ a procedure."
(assemble-program (assemble-program
'((begin-program foo ((name . foo))) '((begin-program foo ((name . foo)))
(begin-standard-arity () 2 #f) (begin-standard-arity () 2 #f)
(load-constant 1 42) (load-constant 0 42)
(return 1) (return 0)
(end-arity) (end-arity)
(end-program))))) (end-program)))))
(pass-if-equal "#<procedure foo (x y)>" (pass-if-equal "#<procedure foo (x y)>"