mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
Reflection support for unboxed f64 slots
* module/system/vm/assembler.scm (emit-definition): Add representation field. (write-arities): Emit representations into the arities section. * module/system/vm/debug.scm (arity-definitions): Read representations. * module/system/vm/frame.scm (<binding>): Add representation field and binding-representation getter. (available-bindings): Pass representation to make-binding. (frame-binding-set!, frame-binding-ref, frame-call-representation): Pass representation to frame-local-ref / frame-local-set!. * test-suite/tests/rtl.test: Update definition instructions. * module/language/cps/slot-allocation.scm ($allocation): Add representations field. (lookup-representation): New public function. (allocate-slots): Pass representations to make-$allocation. * module/language/cps/compile-bytecode.scm (compile-function): Adapt to emit-definition change. * libguile/frames.h: * libguile/frames.c (scm_frame_local_ref, scm_frame_local_set_x): Take representation argument. (scm_to_stack_item_representation): New internal helper.
This commit is contained in:
Andy Wingo
parent
e7660a607c
commit
e3cc0eeb3a
9 changed files with 149 additions and 77 deletions
|
|
@ -475,7 +475,8 @@
|
|||
(for-each (lambda (name var)
|
||||
(let ((slot (maybe-slot var)))
|
||||
(when slot
|
||||
(emit-definition asm name slot))))
|
||||
(let ((repr (lookup-representation var allocation)))
|
||||
(emit-definition asm name slot repr)))))
|
||||
names vars)
|
||||
(when src
|
||||
(emit-source asm src))
|
||||
|
|
|
|||
|
|
@ -35,6 +35,7 @@
|
|||
#:export (allocate-slots
|
||||
lookup-slot
|
||||
lookup-maybe-slot
|
||||
lookup-representation
|
||||
lookup-constant-value
|
||||
lookup-maybe-constant-value
|
||||
lookup-nlocals
|
||||
|
|
@ -43,7 +44,8 @@
|
|||
lookup-slot-map))
|
||||
|
||||
(define-record-type $allocation
|
||||
(make-allocation slots constant-values call-allocs shuffles frame-sizes)
|
||||
(make-allocation slots representations constant-values call-allocs
|
||||
shuffles frame-sizes)
|
||||
allocation?
|
||||
|
||||
;; A map of VAR to slot allocation. A slot allocation is an integer,
|
||||
|
|
@ -51,6 +53,11 @@
|
|||
;;
|
||||
(slots allocation-slots)
|
||||
|
||||
;; A map of VAR to representation. A representation is either 'scm or
|
||||
;; 'f64.
|
||||
;;
|
||||
(representations allocation-representations)
|
||||
|
||||
;; A map of VAR to constant value, for variables with constant values.
|
||||
;;
|
||||
(constant-values allocation-constant-values)
|
||||
|
|
@ -95,6 +102,9 @@
|
|||
(define (lookup-slot var allocation)
|
||||
(intmap-ref (allocation-slots allocation) var))
|
||||
|
||||
(define (lookup-representation var allocation)
|
||||
(intmap-ref (allocation-representations allocation) var))
|
||||
|
||||
(define *absent* (list 'absent))
|
||||
|
||||
(define (lookup-constant-value var allocation)
|
||||
|
|
@ -1006,4 +1016,5 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
(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)))
|
||||
(make-allocation slots constants calls shuffles frame-sizes))))))
|
||||
(make-allocation slots representations constants calls
|
||||
shuffles frame-sizes))))))
|
||||
|
|
|
|||
|
|
@ -113,7 +113,8 @@
|
|||
(format port "~aLocal variables:~%" per-line-prefix)
|
||||
(for-each
|
||||
(lambda (binding)
|
||||
(let ((v (frame-local-ref frame (binding-slot binding))))
|
||||
(let ((v (frame-local-ref frame (binding-slot binding)
|
||||
(binding-representation binding))))
|
||||
(display per-line-prefix port)
|
||||
(run-hook before-print-hook v)
|
||||
(format port "~a = ~v:@y\n" (binding-name binding) width v)))
|
||||
|
|
@ -174,7 +175,8 @@
|
|||
(module-use! mod* mod)
|
||||
(for-each
|
||||
(lambda (binding)
|
||||
(let* ((x (frame-local-ref frame (binding-slot binding)))
|
||||
(let* ((x (frame-local-ref frame (binding-slot binding)
|
||||
(binding-representation binding)))
|
||||
(var (if (variable? x) x (make-variable x))))
|
||||
(format #t
|
||||
"~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n"
|
||||
|
|
|
|||
|
|
@ -1162,10 +1162,9 @@ returned instead."
|
|||
(define-macro-assembler (source asm source)
|
||||
(set-asm-sources! asm (acons (asm-start asm) source (asm-sources asm))))
|
||||
|
||||
(define-macro-assembler (definition asm name slot)
|
||||
(define-macro-assembler (definition asm name slot representation)
|
||||
(let* ((arity (car (meta-arities (car (asm-meta asm)))))
|
||||
(def (vector name
|
||||
slot
|
||||
(def (vector name slot representation
|
||||
(* (- (asm-start asm) (arity-low-pc arity)) 4))))
|
||||
(set-arity-definitions! arity (cons def (arity-definitions arity)))))
|
||||
|
||||
|
|
@ -1876,7 +1875,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
|
|||
(let lp ((definitions (arity-definitions arity)))
|
||||
(match definitions
|
||||
(() relocs)
|
||||
((#(name slot def) . definitions)
|
||||
((#(name slot representation def) . definitions)
|
||||
(let ((sym (if (symbol? name)
|
||||
(string-table-intern! strtab (symbol->string name))
|
||||
0)))
|
||||
|
|
@ -1886,9 +1885,13 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
|
|||
(let lp ((definitions (arity-definitions arity)))
|
||||
(match definitions
|
||||
(() relocs)
|
||||
((#(name slot def) . definitions)
|
||||
((#(name slot representation def) . definitions)
|
||||
(put-uleb128 names-port def)
|
||||
(put-uleb128 names-port slot)
|
||||
(let ((tag (case representation
|
||||
((scm) 0)
|
||||
((f64) 1)
|
||||
(else (error "what!" representation)))))
|
||||
(put-uleb128 names-port (logior (ash slot 2) tag)))
|
||||
(lp definitions))))))
|
||||
(let lp ((metas metas) (pos arities-prefix-len) (relocs '()))
|
||||
(match metas
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Guile runtime debug information
|
||||
|
||||
;;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
|
||||
;;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
|
||||
;;;
|
||||
;;; This library is free software; you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -381,9 +381,14 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
|
|||
(call-with-values (lambda () (read-uleb128 bv pos))
|
||||
(lambda (def-offset pos)
|
||||
(call-with-values (lambda () (read-uleb128 bv pos))
|
||||
(lambda (slot pos)
|
||||
(cons (vector name def-offset slot)
|
||||
(lp pos names))))))))))
|
||||
(lambda (slot+representation pos)
|
||||
(let ((slot (ash slot+representation -2))
|
||||
(representation (case (logand slot+representation #x3)
|
||||
((0) 'scm)
|
||||
((1) 'f64)
|
||||
(else 'unknown))))
|
||||
(cons (vector name def-offset slot representation)
|
||||
(lp pos names)))))))))))
|
||||
(define (load-symbols pos)
|
||||
(let lp ((pos pos) (n nlocals) (out '()))
|
||||
(if (zero? n)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Guile VM frame functions
|
||||
|
||||
;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
|
||||
;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
|
||||
;;;
|
||||
;;; This library is free software; you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -31,6 +31,7 @@
|
|||
#:export (binding-index
|
||||
binding-name
|
||||
binding-slot
|
||||
binding-representation
|
||||
|
||||
frame-bindings
|
||||
frame-lookup-binding
|
||||
|
|
@ -40,11 +41,12 @@
|
|||
frame-object-binding frame-object-name))
|
||||
|
||||
(define-record-type <binding>
|
||||
(make-binding idx name slot)
|
||||
(make-binding idx name slot representation)
|
||||
binding?
|
||||
(idx binding-index)
|
||||
(name binding-name)
|
||||
(slot binding-slot))
|
||||
(slot binding-slot)
|
||||
(representation binding-representation))
|
||||
|
||||
(define (parse-code code)
|
||||
(let ((len (bytevector-length code)))
|
||||
|
|
@ -134,7 +136,7 @@
|
|||
(let lp ((var 0) (pos 0) (pc-offset 0))
|
||||
(when (< var (vector-length defs))
|
||||
(match (vector-ref defs var)
|
||||
(#(name offset slot)
|
||||
(#(name offset slot representation)
|
||||
(when (< offset pc-offset)
|
||||
(error "mismatch between def offsets and parsed code"))
|
||||
(cond
|
||||
|
|
@ -147,7 +149,7 @@
|
|||
|
||||
(define (compute-defs-by-slot defs)
|
||||
(let* ((nslots (match defs
|
||||
(#(#(_ _ slot) ...) (1+ (apply max slot)))))
|
||||
(#(#(_ _ slot _) ...) (1+ (apply max slot)))))
|
||||
(by-slot (make-vector nslots #f)))
|
||||
(let lp ((n 0))
|
||||
(when (< n nslots)
|
||||
|
|
@ -156,7 +158,7 @@
|
|||
(let lp ((n 0))
|
||||
(when (< n (vector-length defs))
|
||||
(match (vector-ref defs n)
|
||||
(#(_ _ slot)
|
||||
(#(_ _ slot _)
|
||||
(bitvector-set! (vector-ref by-slot slot) n #t)
|
||||
(lp (1+ n))))))
|
||||
by-slot))
|
||||
|
|
@ -179,7 +181,7 @@
|
|||
(let lp ((var 0) (pos 0) (pc-offset 0))
|
||||
(when (< var (vector-length defs))
|
||||
(match (vector-ref defs var)
|
||||
(#(name offset slot)
|
||||
(#(name offset slot representation)
|
||||
(when (< offset pc-offset)
|
||||
(error "mismatch between def offsets and parsed code"))
|
||||
(cond
|
||||
|
|
@ -274,10 +276,10 @@
|
|||
(let ((n (bit-position #t live n)))
|
||||
(if n
|
||||
(match (vector-ref defs n)
|
||||
(#(name def-offset slot)
|
||||
(#(name def-offset slot representation)
|
||||
;; Binding 0 is the closure, and is not present
|
||||
;; in arity-definitions.
|
||||
(cons (make-binding (1+ n) name slot)
|
||||
(cons (make-binding (1+ n) name slot representation)
|
||||
(lp (1+ n)))))
|
||||
'()))))
|
||||
(lp (1+ n) (- offset (vector-ref parsed n)))))))
|
||||
|
|
@ -300,17 +302,16 @@
|
|||
(lp (cdr bindings))))))
|
||||
|
||||
(define (frame-binding-set! frame var val)
|
||||
(frame-local-set! frame
|
||||
(binding-slot
|
||||
(or (frame-lookup-binding frame var)
|
||||
(error "variable not bound in frame" var frame)))
|
||||
val))
|
||||
(let ((binding (or (frame-lookup-binding frame var)
|
||||
(error "variable not bound in frame" var frame))))
|
||||
(frame-local-set! frame (binding-slot binding) val
|
||||
(binding-representation binding))))
|
||||
|
||||
(define (frame-binding-ref frame var)
|
||||
(frame-local-ref frame
|
||||
(binding-slot
|
||||
(or (frame-lookup-binding frame var)
|
||||
(error "variable not bound in frame" var frame)))))
|
||||
(let ((binding (or (frame-lookup-binding frame var)
|
||||
(error "variable not bound in frame" var frame))))
|
||||
(frame-local-ref frame (binding-slot binding)
|
||||
(binding-representation binding))))
|
||||
|
||||
|
||||
;; This function is always called to get some sort of representation of the
|
||||
|
|
@ -347,16 +348,21 @@
|
|||
(closure (frame-procedure frame)))
|
||||
(define (find-slot i bindings)
|
||||
(match bindings
|
||||
(#f (and (< i nlocals) i))
|
||||
(() #f)
|
||||
((($ <binding> idx name slot) . bindings)
|
||||
(((and binding ($ <binding> idx name slot)) . bindings)
|
||||
(if (< idx i)
|
||||
(find-slot i bindings)
|
||||
(and (= idx i) slot)))))
|
||||
(and (= idx i) binding)))))
|
||||
(define (local-ref i bindings)
|
||||
(cond
|
||||
((not bindings)
|
||||
;; This case is only hit for primitives and application
|
||||
;; arguments.
|
||||
(frame-local-ref frame i 'scm))
|
||||
((find-slot i bindings)
|
||||
=> (lambda (slot) (frame-local-ref frame slot)))
|
||||
=> (lambda (binding)
|
||||
(frame-local-ref frame (binding-slot binding)
|
||||
(binding-representation binding))))
|
||||
(else
|
||||
'_)))
|
||||
(define (application-arguments)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue