summaryrefslogtreecommitdiff
path: root/module/system
diff options
context:
space:
mode:
Diffstat (limited to 'module/system')
-rw-r--r--module/system/repl/debug.scm6
-rw-r--r--module/system/vm/assembler.scm15
-rw-r--r--module/system/vm/debug.scm13
-rw-r--r--module/system/vm/frame.scm50
4 files changed, 50 insertions, 34 deletions
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 6fff660e5..9516af622 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -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"
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 379539f6a..dd96709e5 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -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
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index cd8c19e13..814472b7a 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -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)
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 7f0211da8..6e4527956 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -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)