mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Reflection support for unboxed f64 slots

Browse source 
* 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 2015-10-28 17:03:42 +00:00
parent e7660a607c
commit e3cc0eeb3a
9 changed files with 149 additions and 77 deletions
Download patch file Download diff file Expand all files Collapse all files

55
libguile/frames.c
View file

@ -220,45 +220,88 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
(SCM frame, SCM index),
enum stack_item_representation
{
STACK_ITEM_SCM = 0,
STACK_ITEM_F64 = 1
};
static enum stack_item_representation
scm_to_stack_item_representation (SCM x, const char *subr, int pos)
{
if (scm_is_eq (x, scm_from_latin1_symbol ("scm")))
return STACK_ITEM_SCM;
if (scm_is_eq (x, scm_from_latin1_symbol ("f64")))
return STACK_ITEM_F64;
scm_wrong_type_arg (subr, pos, x);
return 0; /* Not reached. */
}
SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0,
(SCM frame, SCM index, SCM representation),
"")
#define FUNC_NAME s_scm_frame_local_ref
{
union scm_vm_stack_element *fp, *sp;
unsigned int i;
enum stack_item_representation repr;
SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
repr = scm_to_stack_item_representation (representation, FUNC_NAME, SCM_ARG3);
fp = SCM_VM_FRAME_FP (frame);
sp = SCM_VM_FRAME_SP (frame);
if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
return SCM_FRAME_LOCAL (fp, i);
{
union scm_vm_stack_element *item = SCM_FRAME_SLOT (fp, i);
switch (repr)
{
case STACK_ITEM_SCM:
return item->as_scm;
case STACK_ITEM_F64:
/* return item->as_f64; */
default:
abort();
}
}
SCM_OUT_OF_RANGE (SCM_ARG2, index);
}
#undef FUNC_NAME
/* Need same not-yet-active frame logic here as in frame-num-locals */
SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
(SCM frame, SCM index, SCM val),
SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 4, 0, 0,
(SCM frame, SCM index, SCM val, SCM representation),
"")
#define FUNC_NAME s_scm_frame_local_set_x
{
union scm_vm_stack_element *fp, *sp;
unsigned int i;
enum stack_item_representation repr;
SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
repr = scm_to_stack_item_representation (representation, FUNC_NAME, SCM_ARG3);
fp = SCM_VM_FRAME_FP (frame);
sp = SCM_VM_FRAME_SP (frame);
if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
{
SCM_FRAME_LOCAL (fp, i) = val;
union scm_vm_stack_element *item = SCM_FRAME_SLOT (fp, i);
switch (repr)
{
case STACK_ITEM_SCM:
item->as_scm = val;
break;
case STACK_ITEM_F64:
/* item->as_f64 = scm_to_double (val); */
default:
abort();
}
return SCM_UNSPECIFIED;
}

5
libguile/frames.h
View file

@ -160,8 +160,9 @@ SCM_API SCM scm_frame_call_representation (SCM frame);
SCM_API SCM scm_frame_arguments (SCM frame);
SCM_API SCM scm_frame_source (SCM frame);
SCM_API SCM scm_frame_num_locals (SCM frame);
SCM_API SCM scm_frame_local_ref (SCM frame, SCM index);
SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val);
SCM_API SCM scm_frame_local_ref (SCM frame, SCM index, SCM representation);
SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val,
SCM representation);
SCM_API SCM scm_frame_address (SCM frame);
SCM_API SCM scm_frame_stack_pointer (SCM frame);
SCM_API SCM scm_frame_instruction_pointer (SCM frame);

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

@ -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))

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

@ -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))))))

6
module/system/repl/debug.scm
View file

@ -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"

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

@ -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

13
module/system/vm/debug.scm
View file

@ -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)

50
module/system/vm/frame.scm
View file

@ -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)

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

@ -104,7 +104,7 @@ a procedure."
'((begin-program countdown
((name . countdown)))
(begin-standard-arity (x) 4 #f)
(definition x 1)
(definition x 1 scm)
(br fix-body)
(label loop-head)
(br-if-= 1 2 #f out)
@ -143,7 +143,7 @@ a procedure."
(begin-program accum
((name . accum)))
(begin-standard-arity (x) 4 #f)
(definition x 1)
(definition x 1 scm)
(free-ref 1 3 0)
(box-ref 0 1)
(add 0 0 2)
@ -164,7 +164,7 @@ a procedure."
'((begin-program call
((name . call)))
(begin-standard-arity (f) 7 #f)
(definition f 1)
(definition f 1 scm)
(mov 1 5)
(call 5 1)
(receive 1 5 7)
@ -179,7 +179,7 @@ a procedure."
'((begin-program call-with-3
((name . call-with-3)))
(begin-standard-arity (f) 7 #f)
(definition f 1)
(definition f 1 scm)
(mov 1 5)
(load-constant 0 3)
(call 5 2)
@ -196,7 +196,7 @@ a procedure."
'((begin-program call
((name . call)))
(begin-standard-arity (f) 2 #f)
(definition f 1)
(definition f 1 scm)
(mov 1 0)
(tail-call 1)
(end-arity)
@ -209,7 +209,7 @@ a procedure."
'((begin-program call-with-3
((name . call-with-3)))
(begin-standard-arity (f) 2 #f)
(definition f 1)
(definition f 1 scm)
(mov 1 0) ;; R0 <- R1
(load-constant 0 3) ;; R1 <- 3
(tail-call 2)
@ -234,7 +234,7 @@ a procedure."
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
(begin-standard-arity (x) 3 #f)
(definition x 1)
(definition x 1 scm)
(cached-toplevel-box 0 sqrt-scope sqrt #t)
(box-ref 2 0)
(tail-call 2)
@ -287,7 +287,7 @@ a procedure."
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
(begin-standard-arity (x) 3 #f)
(definition x 1)
(definition x 1 scm)
(cached-module-box 0 (guile) sqrt #t #t)
(box-ref 2 0)
(tail-call 2)
@ -368,8 +368,8 @@ a procedure."
(assemble-program
'((begin-program foo ((name . foo)))
(begin-standard-arity (x y) 3 #f)
(definition x 1)
(definition y 2)
(definition x 1 scm)
(definition y 2 scm)
(load-constant 1 42)
(return-values 2)
(end-arity)
@ -380,9 +380,9 @@ a procedure."
(assemble-program
'((begin-program foo ((name . foo)))
(begin-opt-arity (x) (y) z 4 #f)
(definition x 1)
(definition y 2)
(definition z 3)
(definition x 1 scm)
(definition y 2 scm)
(definition z 3 scm)
(load-constant 2 42)
(return-values 2)
(end-arity)