guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-47-gcb7523


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-47-gcb7523c
Date: Sun, 08 May 2011 14:41:08 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=cb7523c26db24598fb5aa9138598e1b7a3e6370f

The branch, stable-2.0 has been updated
       via  cb7523c26db24598fb5aa9138598e1b7a3e6370f (commit)
       via  f5695488b95263622d5d1202f9f80c624ab4215a (commit)
       via  7e7b8991b295ac9e6b4a79b7fce906b730ce093f (commit)
       via  57b8eca6911758b4bfe5dc5d9184a01c126578ce (commit)
       via  6994fa9fef526782836db8b0b3cedbda18c69da3 (commit)
       via  55fb5058a88b783f0e1b7c375775afeb112dbc0c (commit)
       via  10483f9e6491c8b96167a794115bb4829742f9a6 (commit)
      from  2252321bb77fe83d98d5bcc9db1c76b914e9dd6a (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit cb7523c26db24598fb5aa9138598e1b7a3e6370f
Author: Andy Wingo <address@hidden>
Date:   Sun May 8 16:38:32 2011 +0200

    compile-assembly: cleanup
    
    * module/language/glil/compile-assembly.scm: Clean up code for
      subprograms (not needed, we just cache the glil) and object alists
      (replaced by constants tables).

commit f5695488b95263622d5d1202f9f80c624ab4215a
Author: Andy Wingo <address@hidden>
Date:   Sun May 8 16:37:47 2011 +0200

    compile-assembly: use file-level constants table
    
    * module/language/glil/compile-assembly.scm (compile-assembly): Rework
      to handle toplevel-specific code generation here, instead of in
      glil->assembly.  Specifically, here we build a global constant table,
      and arrange for it to be the objtable of the toplevel thunk.
    
      (compile-program): New helper, compiles a <glil-program> and returns
      just the (load-program ...) form.
    
      (compile-objtable): New helper, generates assembly to build an object
      table, using some other constants table, and possibly recursing to
      `compile-program' for cached GLIL programs.
    
      (glil->assembly): Simplify, removing the toplevel? argument, and
      replacing the object alist with an objtable computed in a previous
      pass.  Adapt to the new form of the objtable, and to use
      compile-program and compile-objtable.

commit 7e7b8991b295ac9e6b4a79b7fce906b730ce093f
Author: Andy Wingo <address@hidden>
Date:   Sun May 8 16:31:18 2011 +0200

    compile-assembly: add dump-constants, a new helper
    
    * module/language/glil/compile-assembly.scm (dump-constants): New
      helper.  Generates bytecode that will result in a vector for the
      global object table being pushed on the stack.  The items in the
      global object table will share state as much as possible.

commit 57b8eca6911758b4bfe5dc5d9184a01c126578ce
Author: Andy Wingo <address@hidden>
Date:   Sun May 8 16:15:25 2011 +0200

    compile-assembly: add build-constant-store, build-object-table
    
    * module/language/glil/compile-assembly.scm (immediate?): New helper.
      (build-constant-store): New helper.  Walks the GLIL tree and builds up
      a constant table, as a vhash.
      (build-object-table): Another helper, builds a constant table for a
      given GLIL program.

commit 6994fa9fef526782836db8b0b3cedbda18c69da3
Author: Andy Wingo <address@hidden>
Date:   Sun May 8 16:13:41 2011 +0200

    compile-assembly: make-meta refactor
    
    * module/language/glil/compile-assembly.scm (make-meta): Avoid going
      through the compiler.

commit 55fb5058a88b783f0e1b7c375775afeb112dbc0c
Author: Andy Wingo <address@hidden>
Date:   Sun May 8 16:09:22 2011 +0200

    compile-assembly: add traversal helpers
    
    * module/language/glil/compile-assembly.scm (vhash-fold-right2):
      (fold2, vector-fold2): Add some traversal helpers that we'll use in
      the next commit.

commit 10483f9e6491c8b96167a794115bb4829742f9a6
Author: Andy Wingo <address@hidden>
Date:   Sun May 8 16:05:27 2011 +0200

    fix `hash' for inf and nan
    
    * libguile/hash.c (scm_hasher): Fix to work on inf and nan.
    * test-suite/tests/hash.test ("hash"): Add tests.

-----------------------------------------------------------------------

Summary of changes:
 libguile/hash.c                           |    3 +-
 module/language/glil/compile-assembly.scm |  738 +++++++++++++++++++++--------
 test-suite/tests/hash.test                |    7 +-
 3 files changed, 538 insertions(+), 210 deletions(-)

diff --git a/libguile/hash.c b/libguile/hash.c
index 0dcd1c2..8448c7c 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -26,6 +26,7 @@
 #include <wchar.h>
 #endif
 
+#include <math.h>
 #include <unistr.h>
 
 #include "libguile/_scm.h"
@@ -192,7 +193,7 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
       case scm_tc16_real:
        {
          double r = SCM_REAL_VALUE (obj);
-         if (floor (r) == r) 
+         if (floor (r) == r && !isinf (r) && !isnan (r))
            {
              obj = scm_inexact_to_exact (obj);
              return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
diff --git a/module/language/glil/compile-assembly.scm 
b/module/language/glil/compile-assembly.scm
index 76c19b4..d02b903 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM assembler
 
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011 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
@@ -26,10 +26,36 @@
   #:use-module (system vm instruction)
   #:use-module ((system vm program) #:select (make-binding))
   #:use-module (ice-9 receive)
+  #:use-module (ice-9 vlist)
   #:use-module ((srfi srfi-1) #:select (fold))
   #:use-module (rnrs bytevectors)
   #:export (compile-assembly))
 
+;; Traversal helpers
+;;
+(define (vhash-fold-right2 proc vhash s0 s1)
+  (let lp ((i (vlist-length vhash)) (s0 s0) (s1 s1))
+    (if (zero? i)
+        (values s0 s1)
+        (receive (s0 s1) (let ((pair (vlist-ref vhash (1- i))))
+                           (proc (car pair) (cdr pair) s0 s1))
+          (lp (1- i) s0 s1)))))
+
+(define (fold2 proc ls s0 s1)
+  (let lp ((ls ls) (s0 s0) (s1 s1))
+    (if (null? ls)
+        (values s0 s1)
+        (receive (s0 s1) (proc (car ls) s0 s1)
+          (lp (cdr ls) s0 s1)))))
+
+(define (vector-fold2 proc vect s0 s1)
+  (let ((len (vector-length vect)))
+    (let lp ((i 0) (s0 s0) (s1 s1))
+      (if (< i len)
+          (receive (s0 s1) (proc (vector-ref vect i) s0 s1)
+            (lp (1+ i) s0 s1))
+          (values s0 s1)))))
+
 ;; Variable cache cells go in the object table, and serialize as their
 ;; keys. The reason we wrap the keys in these records is so they don't
 ;; compare as `equal?' to other objects in the object table.
@@ -38,13 +64,6 @@
 
 (define-record <variable-cache-cell> key)
 
-;; Subprograms can be loaded into an object table as well. We need a
-;; disjoint type here too. (Subprograms have their own object tables --
-;; though probably we should just make one table per compilation unit.)
-
-(define-record <subprogram> table prog)
-
-
 (define (limn-sources sources)
   (let lp ((in sources) (out '()) (filename #f))
     (if (null? in)
@@ -68,16 +87,130 @@
            (else
             (lp (cdr in) out filename)))))))
 
+
+;; Avoid going through the compiler so as to avoid adding to the
+;; constant store.
 (define (make-meta bindings sources arities tail)
-  ;; sounds silly, but the only case in which we have no arities is when
-  ;; compiling a meta procedure.
-  (if (and (null? bindings) (null? sources) (null? arities) (null? tail))
-      #f
-      (compile-assembly
-       (make-glil-program '()
-                          (list
-                           (make-glil-const `(,bindings ,sources ,arities 
,@tail))
-                           (make-glil-call 'return 1))))))
+  (let ((body `(,@(dump-object `(,bindings ,sources ,arities ,@tail) 0)
+                (return))))
+    `(load-program ()
+                   ,(addr+ 0 body)
+                   #f
+                   ,@body)))
+
+;; If this is true, the object doesn't need to go in a constant table.
+;;
+(define (immediate? x)
+  (object->assembly x))
+
+;; Note: in all of these procedures that build up constant tables, the
+;; first (zeroth) index is reserved.  At runtime it is replaced with the
+;; procedure's module.  Hence all of this 1+ length business.
+
+;; Build up a vhash of constant -> index, allowing us to build up a
+;; constant table for a whole compilation unit.
+;;
+(define (build-constant-store x)
+  (define (add-to-store store x)
+    (define (add-to-end store x)
+      (vhash-cons x (1+ (vlist-length store)) store))
+    (cond
+     ((vhash-assoc x store)
+      ;; Already in the store.
+      store)
+     ((immediate? x)
+      ;; Immediates don't need to go in the constant table.
+      store)
+     ((or (number? x)
+          (string? x)
+          (symbol? x)
+          (keyword? x))
+      ;; Atoms.
+      (add-to-end store x))
+     ((variable-cache-cell? x)
+      ;; Variable cache cells (see below).
+      (add-to-end (add-to-store store (variable-cache-cell-key x))
+                  x))
+     ((list? x)
+      ;; Add the elements to the store, then the list itself.  We could
+      ;; try hashing the cdrs as well, but that seems a bit overkill, and
+      ;; this way we do compress the bytecode a bit by allowing the use of
+      ;; the `list' opcode.
+      (let ((store (fold (lambda (x store)
+                           (add-to-store store x))
+                         store
+                         x)))
+        (add-to-end store x)))
+     ((pair? x)
+      ;; Non-lists get caching on both fields.
+      (let ((store (add-to-store (add-to-store store (car x))
+                                 (cdr x))))
+        (add-to-end store x)))
+     ((and (vector? x)
+           (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
+      ;; Likewise, add the elements to the store, then the vector itself.
+      ;; Important for the vectors produced by the psyntax expansion
+      ;; process.
+      (let ((store (fold (lambda (x store)
+                           (add-to-store store x))
+                         store
+                         (vector->list x))))
+        (add-to-end store x)))
+     ((array? x)
+      ;; Naive assumption that if folks are using arrays, that perhaps
+      ;; there's not much more duplication.
+      (add-to-end store x))
+     (else
+      (error "build-constant-store: unrecognized object" x))))
+
+  (let walk ((x x) (store vlist-null))
+    (record-case x
+      ((<glil-program> meta body)
+       (fold walk store body))
+      ((<glil-const> obj)
+       (add-to-store store obj))
+      ((<glil-kw-prelude> kw)
+       (add-to-store store kw))
+      ((<glil-toplevel> op name)
+       ;; We don't add toplevel variable cache cells to the global
+       ;; constant table, because they are sensitive to changes in
+       ;; modules as the toplevel expressions are evaluated.  So we just
+       ;; add the name.
+       (add-to-store store name))
+      ((<glil-module> op mod name public?)
+       ;; However, it is fine add module variable cache cells to the
+       ;; global table, as their bindings are not dependent on the
+       ;; current module.
+       (add-to-store store
+                     (make-variable-cache-cell (list mod name public?))))
+      (else store))))
+
+;; Analyze one <glil-program> to determine its object table.  Produces a
+;; vhash of constant to index.
+;;
+(define (build-object-table x)
+  (define (add store x)
+    (vhash-cons x (1+ (vlist-length store)) store))
+  (record-case x
+    ((<glil-program> meta body)
+     (fold (lambda (x table)
+             (record-case x
+               ((<glil-program> meta body)
+                ;; Add the GLIL itself to the table.
+                (add table x))
+               ((<glil-const> obj)
+                (if (immediate? obj)
+                    table
+                    (add table obj)))
+               ((<glil-kw-prelude> kw)
+                (add table kw))
+               ((<glil-toplevel> op name)
+                (add table (make-variable-cache-cell name)))
+               ((<glil-module> op mod name public?)
+                (add table (make-variable-cache-cell (list mod name public?))))
+               (else table)))
+           vlist-null
+           body))))
 
 ;; A functional stack of names of live variables.
 (define (make-open-binding name boxed? index)
@@ -115,21 +248,6 @@
                         (lambda (x y) (< (car x) (car y)))))
       (close-all-bindings (close-binding bindings end) end)))
 
-;; A functional object table.
-(define *module* 1)
-(define (assoc-ref-or-acons alist x make-y)
-  (cond ((assoc-ref alist x)
-         => (lambda (y) (values y alist)))
-        (else
-         (let ((y (make-y x alist)))
-           (values y (acons x y alist))))))
-(define (object-index-and-alist x alist)
-  (assoc-ref-or-acons alist x
-                      (lambda (x alist)
-                        (+ (length alist) *module*))))
-(define (make-object-table objects)
-  (and (not (null? objects))
-       (list->vector (cons #f objects))))
 
 ;; A functional arities thingamajiggy.
 ;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...)
@@ -152,82 +270,151 @@
   (open-arity start nreq nopt rest kw (close-arity end arities)))
 
 (define (compile-assembly glil)
-  (receive (code . _)
-      (glil->assembly glil #t '(()) '() '() #f '() -1)
-    (car code)))
+  (let* ((all-constants (build-constant-store glil))
+         (prog (compile-program glil all-constants))
+         (len (byte-length prog)))
+    ;; The top objcode thunk.  We're going to wrap this thunk in
+    ;; a thunk -- yo dawgs -- with the goal being to lift all
+    ;; constants up to the top level.  The store forms a DAG, so
+    ;; we can actually build up later elements in terms of
+    ;; earlier ones.
+    ;;
+    (cond
+     ((vlist-null? all-constants)
+      ;; No constants: just emit the inner thunk.
+      prog)
+     (else
+      ;; We have an object store, so write it out, attach it
+      ;; to the inner thunk, and tail call.
+      (receive (tablecode addr) (dump-constants all-constants)
+        (let ((prog (align-program prog addr)))
+          ;; Outer thunk.
+          `(load-program ()
+                         ,(+ (addr+ addr prog)
+                             2          ; for (tail-call 0)
+                             )
+                         #f
+                         ;; Load the table, build the inner
+                         ;; thunk, then tail call.
+                         ,@tablecode
+                         ,@prog
+                         (tail-call 0))))))))
 
-(define (glil->assembly glil toplevel? bindings
-                        source-alist label-alist object-alist arities addr)
+(define (compile-program glil constants)
+  (record-case glil
+    ((<glil-program> meta body)
+     (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
+              (label-alist '()) (arities '()) (addr 0))
+       (cond
+        ((null? body)
+         (let ((code (fold append '() code))
+               (bindings (close-all-bindings bindings addr))
+               (sources (limn-sources (reverse! source-alist)))
+               (labels (reverse label-alist))
+               (arities (reverse (close-arity addr arities)))
+               (len addr))
+           (let* ((meta (make-meta bindings sources arities meta))
+                  (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0)))
+             `(load-program ,labels
+                            ,(+ len meta-pad)
+                            ,meta
+                            ,@code
+                            ,@(if meta
+                                  (make-list meta-pad '(nop))
+                                  '())))))
+        (else
+         (receive (subcode bindings source-alist label-alist arities)
+             (glil->assembly (car body) bindings
+                             source-alist label-alist
+                             constants arities addr)
+           (lp (cdr body) (cons subcode code)
+               bindings source-alist label-alist arities
+               (addr+ addr subcode)))))))))
+
+(define (compile-objtable constants table addr)
+  (define (load-constant idx)
+    (if (< idx 256)
+        (values `((object-ref ,idx))
+                2)
+        (values `((long-object-ref
+                   ,(quotient idx 256) ,(modulo idx 256)))
+                3)))
+  (cond
+   ((vlist-null? table)
+    ;; Empty table; just return #f.
+    (values '((make-false))
+            (1+ addr)))
+   (else
+    (call-with-values
+        (lambda ()
+          (vhash-fold-right2
+           (lambda (obj idx codes addr)
+             (cond
+              ((vhash-assoc obj constants)
+               => (lambda (pair)
+                    (receive (load len) (load-constant (cdr pair))
+                      (values (cons load codes)
+                              (+ addr len)))))
+              ((variable-cache-cell? obj)
+               (cond
+                ((vhash-assoc (variable-cache-cell-key obj) constants)
+                 => (lambda (pair)
+                      (receive (load len) (load-constant (cdr pair))
+                        (values (cons load codes)
+                                (+ addr len)))))
+                (else (error "vcache cell key not in table" obj))))
+              ((glil-program? obj)
+               ;; Programs are not cached in the global constants
+               ;; table because when a program is loaded, its module
+               ;; is bound, and we want to do that only after any
+               ;; preceding effectful statements.
+               (let* ((table (build-object-table obj))
+                      (prog (compile-program obj table)))
+                 (receive (tablecode addr)
+                     (compile-objtable constants table addr)
+                   (let ((prog (align-program prog addr)))
+                     (values (cons `(,@tablecode ,@prog)
+                                   codes)
+                             (addr+ addr prog))))))
+              (else
+               (error "unrecognized constant" obj))))
+           table
+           '(((make-false))) (1+ addr)))
+      (lambda (elts addr)
+        (let ((len (1+ (vlist-length table))))
+          (values
+           (fold append
+                 `((vector ,(quotient len 256) ,(modulo len 256)))
+                 elts)
+           (+ addr 3))))))))
+
+(define (glil->assembly glil bindings source-alist label-alist
+                        constants arities addr)
   (define (emit-code x)
-    (values x bindings source-alist label-alist object-alist arities))
-  (define (emit-code/object x object-alist)
-    (values x bindings source-alist label-alist object-alist arities))
+    (values x bindings source-alist label-alist arities))
+  (define (emit-object-ref i)
+    (values (if (< i 256)
+                `((object-ref ,i))
+                `((long-object-ref ,(quotient i 256) ,(modulo i 256))))
+            bindings source-alist label-alist arities))
   (define (emit-code/arity x nreq nopt rest kw)
-    (values x bindings source-alist label-alist object-alist
+    (values x bindings source-alist label-alist
             (begin-arity addr (addr+ addr x) nreq nopt rest kw arities)))
   
   (record-case glil
     ((<glil-program> meta body)
-     (define (process-body)
-       (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
-                (label-alist '()) (object-alist (if toplevel? #f '()))
-                (arities '()) (addr 0))
-         (cond
-          ((null? body)
-           (values (reverse code)
-                   (close-all-bindings bindings addr)
-                   (limn-sources (reverse! source-alist))
-                   (reverse label-alist)
-                   (and object-alist (map car (reverse object-alist)))
-                   (reverse (close-arity addr arities))
-                   addr))
-          (else
-           (receive (subcode bindings source-alist label-alist object-alist
-                     arities)
-               (glil->assembly (car body) #f bindings
-                               source-alist label-alist object-alist
-                               arities addr)
-             (lp (cdr body) (append (reverse subcode) code)
-                 bindings source-alist label-alist object-alist arities
-                 (addr+ addr subcode)))))))
-
-     (receive (code bindings sources labels objects arities len)
-         (process-body)
-       (let* ((meta (make-meta bindings sources arities meta))
-              (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
-              (prog `(load-program ,labels
-                                  ,(+ len meta-pad)
-                                  ,meta
-                                  ,@code
-                                  ,@(if meta
-                                        (make-list meta-pad '(nop))
-                                        '()))))
-         (cond
-          (toplevel?
-           ;; toplevel bytecode isn't loaded by the vm, no way to do
-           ;; object table or closure capture (not in the bytecode,
-           ;; anyway)
-           (emit-code (align-program prog addr)))
-          (else
-           (let ((table (make-object-table objects)))
-             (cond
-              (object-alist
-               ;; if we are being compiled from something with an object
-               ;; table, cache the program there
-               (receive (i object-alist)
-                   (object-index-and-alist (make-subprogram table prog)
-                                           object-alist)
-                 (emit-code/object `(,(if (< i 256)
-                                          `(object-ref ,i)
-                                          `(long-object-ref ,(quotient i 256)
-                                                            ,(modulo i 256))))
-                                   object-alist)))
-              (else
-               ;; otherwise emit a load directly
-               (let ((table-code (dump-object table addr)))
-                 (emit-code
-                  `(,@table-code
-                    ,@(align-program prog (addr+ addr table-code)))))))))))))
+     (cond
+      ((vhash-assoc glil constants)
+       ;; We are cached in someone's objtable; just emit a load.
+       => (lambda (pair)
+            (emit-object-ref (cdr pair))))
+      (else
+       ;; Otherwise, build an objtable for the program, compile it, and
+       ;; emit a load-program.
+       (let* ((table (build-object-table glil))
+              (prog (compile-program glil table)))
+         (receive (tablecode addr) (compile-objtable constants table addr)
+           (emit-code `(,@tablecode ,@(align-program prog addr))))))))
     
     ((<glil-std-prelude> nreq nlocs else-label)
      (emit-code/arity
@@ -277,61 +464,60 @@
         nreq nopt rest #f)))
     
     ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
-     (receive (kw-idx object-alist)
-         (object-index-and-alist kw object-alist)
-       (let* ((bind-required
-               (if else-label
-                   `((br-if-nargs-lt ,(quotient nreq 256)
-                                     ,(modulo nreq 256)
-                                     ,else-label))
-                   `((assert-nargs-ge ,(quotient nreq 256)
-                                      ,(modulo nreq 256)))))
-              (ntotal (apply max (+ nreq nopt) (map 1+ (map cdr kw))))
-              (bind-optionals-and-shuffle
-               `((bind-optionals/shuffle
-                  ,(quotient nreq 256)
-                  ,(modulo nreq 256)
-                  ,(quotient (+ nreq nopt) 256)
-                  ,(modulo (+ nreq nopt) 256)
-                  ,(quotient ntotal 256)
-                  ,(modulo ntotal 256))))
-              (bind-kw
-               ;; when this code gets called, all optionals are filled
-               ;; in, space has been made for kwargs, and the kwargs
-               ;; themselves have been shuffled above the slots for all
-               ;; req/opt/kwargs locals.
-               `((bind-kwargs
-                  ,(quotient kw-idx 256)
-                  ,(modulo kw-idx 256)
-                  ,(quotient ntotal 256)
-                  ,(modulo ntotal 256)
-                  ,(logior (if rest 2 0)
-                           (if allow-other-keys? 1 0)))))
-              (bind-rest
-               (if rest
-                   `((bind-rest ,(quotient ntotal 256)
-                                ,(modulo ntotal 256)
-                                ,(quotient rest 256)
-                                ,(modulo rest 256)))
-                   '())))
+     (let* ((kw-idx (or (and=> (vhash-assoc kw constants) cdr)
+                        (error "kw not in objtable")))
+            (bind-required
+             (if else-label
+                 `((br-if-nargs-lt ,(quotient nreq 256)
+                                   ,(modulo nreq 256)
+                                   ,else-label))
+                 `((assert-nargs-ge ,(quotient nreq 256)
+                                    ,(modulo nreq 256)))))
+            (ntotal (apply max (+ nreq nopt) (map 1+ (map cdr kw))))
+            (bind-optionals-and-shuffle
+             `((bind-optionals/shuffle
+                ,(quotient nreq 256)
+                ,(modulo nreq 256)
+                ,(quotient (+ nreq nopt) 256)
+                ,(modulo (+ nreq nopt) 256)
+                ,(quotient ntotal 256)
+                ,(modulo ntotal 256))))
+            (bind-kw
+             ;; when this code gets called, all optionals are filled
+             ;; in, space has been made for kwargs, and the kwargs
+             ;; themselves have been shuffled above the slots for all
+             ;; req/opt/kwargs locals.
+             `((bind-kwargs
+                ,(quotient kw-idx 256)
+                ,(modulo kw-idx 256)
+                ,(quotient ntotal 256)
+                ,(modulo ntotal 256)
+                ,(logior (if rest 2 0)
+                         (if allow-other-keys? 1 0)))))
+            (bind-rest
+             (if rest
+                 `((bind-rest ,(quotient ntotal 256)
+                              ,(modulo ntotal 256)
+                              ,(quotient rest 256)
+                              ,(modulo rest 256)))
+                 '())))
          
-         (let ((code `(,@bind-required
-                       ,@bind-optionals-and-shuffle
-                       ,@bind-kw
-                       ,@bind-rest
-                       (reserve-locals ,(quotient nlocs 256)
-                                       ,(modulo nlocs 256)))))
-           (values code bindings source-alist label-alist object-alist
-                   (begin-arity addr (addr+ addr code) nreq nopt rest
-                                (and kw (cons allow-other-keys? kw))
-                                arities))))))
+       (let ((code `(,@bind-required
+                     ,@bind-optionals-and-shuffle
+                     ,@bind-kw
+                     ,@bind-rest
+                     (reserve-locals ,(quotient nlocs 256)
+                                     ,(modulo nlocs 256)))))
+         (values code bindings source-alist label-alist
+                 (begin-arity addr (addr+ addr code) nreq nopt rest
+                              (and kw (cons allow-other-keys? kw))
+                              arities)))))
     
     ((<glil-bind> vars)
      (values '()
              (open-binding bindings vars addr)
              source-alist
              label-alist
-             object-alist
              arities))
 
     ((<glil-mv-bind> vars rest)
@@ -340,13 +526,11 @@
                  bindings
                  source-alist
                  label-alist
-                 object-alist
                  arities)
          (values `((truncate-values ,(length vars) ,(if rest 1 0)))
                  (open-binding bindings vars addr)
                  source-alist
                  label-alist
-                 object-alist
                  arities)))
     
     ((<glil-unbind>)
@@ -354,7 +538,6 @@
              (close-binding bindings addr)
              source-alist
              label-alist
-             object-alist
              arities))
              
     ((<glil-source> props)
@@ -362,7 +545,6 @@
              bindings
              (acons addr props source-alist)
              label-alist
-             object-alist
              arities))
 
     ((<glil-void>)
@@ -373,16 +555,10 @@
       ((object->assembly obj)
        => (lambda (code)
             (emit-code (list code))))
-      ((not object-alist)
-       (emit-code (dump-object obj addr)))
-      (else
-       (receive (i object-alist)
-           (object-index-and-alist obj object-alist)
-         (emit-code/object (if (< i 256)
-                               `((object-ref ,i))
-                               `((long-object-ref ,(quotient i 256)
-                                                  ,(modulo i 256))))
-                           object-alist)))))
+      ((vhash-assoc obj constants)
+       => (lambda (pair)
+            (emit-object-ref (cdr pair))))
+      (else (error "const not in table" obj))))
 
     ((<glil-lexical> local? boxed? op index)
      (emit-code
@@ -442,30 +618,38 @@
      (case op
        ((ref set)
         (cond
-         ((not object-alist)
-          (emit-code `(,@(dump-object name addr)
-                       (link-now)
-                       ,(case op 
-                          ((ref) '(variable-ref))
-                          ((set) '(variable-set))))))
+         ((and=> (vhash-assoc (make-variable-cache-cell name) constants)
+                 cdr)
+          => (lambda (i)
+               (emit-code (if (< i 256)
+                              `((,(case op
+                                    ((ref) 'toplevel-ref)
+                                    ((set) 'toplevel-set))
+                                 ,i))
+                              `((,(case op
+                                    ((ref) 'long-toplevel-ref)
+                                    ((set) 'long-toplevel-set))
+                                 ,(quotient i 256)
+                                 ,(modulo i 256)))))))
          (else
-          (receive (i object-alist)
-              (object-index-and-alist (make-variable-cache-cell name)
-                                      object-alist)
-            (emit-code/object (if (< i 256)
-                                  `((,(case op
-                                        ((ref) 'toplevel-ref)
-                                        ((set) 'toplevel-set))
-                                     ,i))
-                                  `((,(case op
-                                        ((ref) 'long-toplevel-ref)
-                                        ((set) 'long-toplevel-set))
-                                     ,(quotient i 256)
-                                     ,(modulo i 256))))
-                              object-alist)))))
+          (let ((i (or (and=> (vhash-assoc name constants) cdr)
+                       (error "toplevel name not in objtable" name))))
+            (emit-code `(,(if (< i 256)
+                              `(object-ref ,i)
+                              `(long-object-ref ,(quotient i 256)
+                                                ,(modulo i 256)))
+                         (link-now)
+                         ,(case op
+                            ((ref) '(variable-ref))
+                            ((set) '(variable-set)))))))))
        ((define)
-        (emit-code `(,@(dump-object name addr)
-                     (define))))
+        (let ((i (or (and=> (vhash-assoc name constants) cdr)
+                     (error "toplevel name not in objtable" name))))
+          (emit-code `(,(if (< i 256)
+                            `(object-ref ,i)
+                            `(long-object-ref ,(quotient i 256)
+                                              ,(modulo i 256)))
+                       (define)))))
        (else
         (error "unknown toplevel var kind" op name))))
 
@@ -473,21 +657,19 @@
      (let ((key (list mod name public?)))
        (case op
          ((ref set)
-          (cond
-           ((not object-alist)
-            (emit-code `(,@(dump-object key addr)
-                         (link-now)
-                         ,(case op 
-                            ((ref) '(variable-ref))
-                            ((set) '(variable-set))))))
-           (else
-            (receive (i object-alist)
-                (object-index-and-alist (make-variable-cache-cell key)
-                                        object-alist)
-              (emit-code/object (case op
-                                  ((ref) `((toplevel-ref ,i)))
-                                  ((set) `((toplevel-set ,i))))
-                                object-alist)))))
+          (let ((i (or (and=> (vhash-assoc (make-variable-cache-cell key)
+                                           constants) cdr)
+                       (error "module vcache not in objtable" key))))
+            (emit-code (if (< i 256)
+                           `((,(case op
+                                 ((ref) 'toplevel-ref)
+                                 ((set) 'toplevel-set))
+                              ,i))
+                           `((,(case op
+                                 ((ref) 'long-toplevel-ref)
+                                 ((set) 'long-toplevel-set))
+                              ,(quotient i 256)
+                              ,(modulo i 256)))))))
          (else
           (error "unknown module var kind" op key)))))
 
@@ -497,7 +679,6 @@
                bindings
                source-alist
                (acons label (addr+ addr code) label-alist)
-               object-alist
                arities)))
 
     ((<glil-branch> inst label)
@@ -533,11 +714,6 @@
   (cond
    ((object->assembly x) => list)
    ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
-   ((subprogram? x)
-    (let ((table-code (dump-object (subprogram-table x) addr)))
-      `(,@table-code
-        ,@(align-program (subprogram-prog x)
-                         (addr+ addr table-code)))))
    ((number? x)
     `((load-number ,(number->string x))))
    ((string? x)
@@ -608,5 +784,153 @@
                                 ,(logand #xff len)))
                   codes)))))
    (else
-    (error "assemble: unrecognized object" x))))
+    (error "dump-object: unrecognized object" x))))
+
+(define (dump-constants constants)
+  (define (ref-or-dump x i addr)
+    (let ((pair (vhash-assoc x constants)))
+      (if (and pair (< (cdr pair) i))
+          (let ((idx (cdr pair)))
+            (if (< idx 256)
+                (values `((object-ref ,idx))
+                        (+ addr 2))
+                (values `((long-object-ref ,(quotient idx 256)
+                                           ,(modulo idx 256)))
+                        (+ addr 3))))
+          (dump1 x i addr))))
+  (define (dump1 x i addr)
+    (cond
+     ((object->assembly x)
+      => (lambda (code)
+           (values (list code)
+                   (+ (byte-length code) addr))))
+     ((or (number? x)
+          (string? x)
+          (symbol? x)
+          (keyword? x))
+      ;; Atoms.
+      (let ((code (dump-object x addr)))
+        (values code (addr+ addr code))))
+     ((variable-cache-cell? x)
+      (dump1 (variable-cache-cell-key x) i addr))
+     ((list? x)
+      (receive (codes addr)
+          (fold2 (lambda (x codes addr)
+                   (receive (subcode addr) (ref-or-dump x i addr)
+                     (values (cons subcode codes) addr)))
+                 x '() addr)
+        (values (fold append
+                      (let ((len (length x)))
+                        `((list ,(quotient len 256) ,(modulo len 256))))
+                      codes)
+                (+ addr 3))))
+     ((pair? x)
+      (receive (car-code addr) (ref-or-dump (car x) i addr)
+        (receive (cdr-code addr) (ref-or-dump (cdr x) i addr)
+          (values `(,@car-code ,@cdr-code (cons))
+                  (1+ addr)))))
+     ((and (vector? x)
+           (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
+      (receive (codes addr)
+          (vector-fold2 (lambda (x codes addr)
+                          (receive (subcode addr) (ref-or-dump x i addr)
+                            (values (cons subcode codes) addr)))
+                        x '() addr)
+        (values (fold append
+                      (let ((len (vector-length x)))
+                        `((vector ,(quotient len 256) ,(modulo len 256))))
+                      codes)
+                (+ addr 3))))
+     ((and (array? x) (symbol? (array-type x)))
+      (receive (type addr) (ref-or-dump (array-type x) i addr)
+        (receive (shape addr) (ref-or-dump (array-shape x) i addr)
+          (let ((bv (align-code `(load-array ,(uniform-array->bytevector x))
+                                addr 8 4)))
+            (values `(,@type ,@shape ,@bv)
+                    (addr+ addr bv))))))
+     ((array? x)
+      (let ((contents (array-contents x)))
+        (receive (codes addr)
+            (vector-fold2 (lambda (x codes addr)
+                            (receive (subcode addr) (ref-or-dump x i addr)
+                              (values (cons subcode codes) addr)))
+                          x '() addr)
+          (receive (shape addr) (ref-or-dump (array-shape x) i addr)
+            (values (fold append
+                          (let ((len (vector-length contents)))
+                            `(,@shape
+                              (make-array ,(quotient (ash len -16) 256)
+                                          ,(logand #xff (ash len -8))
+                                          ,(logand #xff len))))
+                          codes)
+                    (+ addr 4))))))
+     (else
+      (error "write-table: unrecognized object" x))))
 
+  (receive (codes addr)
+      (vhash-fold-right2 (lambda (obj idx code addr)
+                           ;; The vector is on the stack.  Dup it, push
+                           ;; the index, push the val, then vector-set.
+                           (let ((pre `((dup)
+                                        ,(object->assembly idx))))
+                             (receive (valcode addr) (dump1 obj idx
+                                                            (addr+ addr pre))
+                               (values (cons* '((vector-set))
+                                              valcode
+                                              pre
+                                              code)
+                                       (1+ addr)))))
+                         constants
+                         '(((assert-nargs-ee/locals 1)
+                            ;; Push the vector.
+                            (local-ref 0)))
+                         4)
+    (let* ((len (1+ (vlist-length constants)))
+           (pre-prog-addr (+ 2          ; reserve-locals
+                             len 3      ; empty vector
+                             2          ; local-set
+                             1          ; new-frame
+                             2          ; local-ref
+                             ))
+           (prog (align-program
+                  `(load-program ()
+                                 ,(+ addr 1)
+                                 #f
+                                 ;; The `return' will be at the tail of the
+                                 ;; program.  The vector is already pushed
+                                 ;; on the stack.
+                                 . ,(fold append '((return)) codes))
+                  pre-prog-addr)))
+      (values `(;; Reserve storage for the vector.
+                (assert-nargs-ee/locals ,(logior 0 (ash 1 3)))
+                ;; Push the vector, and store it in slot 0.
+                ,@(make-list len '(make-false))
+                (vector ,(quotient len 256) ,(modulo len 256))
+                (local-set 0)
+                ;; Now we open the call frame.
+                ;;
+                (new-frame)
+                ;; Now build a thunk to init the constants.  It will
+                ;; have the unfinished constant table both as its
+                ;; argument and as its objtable.  The former allows it
+                ;; to update the objtable, with vector-set!, and the
+                ;; latter allows init code to refer to previously set
+                ;; values.
+                ;;
+                ;; Grab the vector, to be the objtable.
+                (local-ref 0)
+                ;; Now the load-program, properly aligned.  Pops the vector.
+                ,@prog
+                ;; Grab the vector, as an argument this time.
+                (local-ref 0)
+                ;; Call the init thunk with the vector as an arg.
+                (call 1)
+                ;; The thunk also returns the vector.  Leave it on the
+                ;; stack for compile-assembly to use.
+                )
+              ;; The byte length of the init code, which we can
+              ;; determine without folding over the code again.
+              (+ (addr+ pre-prog-addr prog) ; aligned program
+                 2 ; local-ref
+                 2 ; call
+                 )))))
diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test
index d2bde48..f3d603d 100644
--- a/test-suite/tests/hash.test
+++ b/test-suite/tests/hash.test
@@ -1,6 +1,6 @@
 ;;;; hash.test --- test guile hashing     -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011 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
@@ -32,7 +32,10 @@
     (hash #t 0))
   (pass-if (= 0 (hash #t 1)))
   (pass-if (= 0 (hash #f 1)))
-  (pass-if (= 0 (hash noop 1))))
+  (pass-if (= 0 (hash noop 1)))
+  (pass-if (= 0 (hash +inf.0 1)))
+  (pass-if (= 0 (hash -inf.0 1)))
+  (pass-if (= 0 (hash +nan.0 1))))
 
 ;;;
 ;;; hashv


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]