[Guile-commits] 02/36: intern arbitrary constants

[Christopher Allan Webber]

cwebber pushed a commit to branch wip-elisp
in repository guile.

commit d808027782a7ac978a26bf3bd904c58a133316e1
Author: Robin Templeton <address@hidden>
Date:   Tue Jun 10 18:48:07 2014 -0400

    intern arbitrary constants
    
    (Best-ability ChangeLog annotation added by Christopher Allan Webber.)
    
    * libguile/loader.c (load_thunk_from_memory): Refactor, adding
      "constants" argument and passing to "init" if appropriate.
      (load_thunk_from_file): Call "load-thunk-from-memory" with
      "constants" set to #f.
      (scm_load_thunk_from_memory): Instead of a bytevector, accept
      a cons of "(bytevector . constants)", where constants is either
      a vector or #f.  Pass this into "load_thunk_from_memory".
    * module/language/bytecode/spec.scm: Adapt printer.
    * module/language/cps/compile-bytecode.scm (compile-bytecode):
      New variable.
    * module/system/repl/command.scm (disassemble):
      Adapt to expect pair which includes bytevector as its car.
    * module/system/vm/assembler.scm <asm>: Add "to-file?" slot.
      (fresh-block): New variable.
      (make-assembler): Adapt to expect "to-file?" keyword argument.
      (intern-constant): Support "asm-to-file?" in checks.
      (emit-init-constants, link-data): Likewise.
      (link-assembly): Update logic for handling "(bytevector . constants)"
      pair, as well as the expectations of its invocation by compile-bytecode.
---
 libguile/loader.c                        |   23 +++++++++++++++-----
 module/language/bytecode/spec.scm        |    3 +-
 module/language/cps/compile-bytecode.scm |   18 +++++++++++++++
 module/system/repl/command.scm           |    2 +-
 module/system/vm/assembler.scm           |   34 ++++++++++++++++++++++-------
 5 files changed, 64 insertions(+), 16 deletions(-)

diff --git a/libguile/loader.c b/libguile/loader.c
index 97effb3..2bd4f4f 100644
--- a/libguile/loader.c
+++ b/libguile/loader.c
@@ -342,7 +342,7 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
 #define ABORT(msg) do { err_msg = msg; goto cleanup; } while (0)
 
 static SCM
-load_thunk_from_memory (char *data, size_t len, int is_read_only)
+load_thunk_from_memory (char *data, size_t len, int is_read_only, SCM 
constants)
 #define FUNC_NAME "load-thunk-from-memory"
 {
   Elf_Ehdr *header;
@@ -447,7 +447,12 @@ load_thunk_from_memory (char *data, size_t len, int 
is_read_only)
     goto cleanup;
 
   if (scm_is_true (init))
-    scm_call_0 (init);
+    {
+      if (scm_is_true (constants))
+        scm_call_1 (init, constants);
+      else
+        scm_call_0 (init);
+    }
 
   register_elf (data, len, frame_maps);
 
@@ -552,19 +557,25 @@ SCM_DEFINE (scm_load_thunk_from_file, 
"load-thunk-from-file", 1, 0, 0,
 
   (void) close (fd);
 
-  return load_thunk_from_memory (data, end, is_read_only);
+  return load_thunk_from_memory (data, end, is_read_only, SCM_BOOL_F);
 }
 #undef FUNC_NAME
 
 SCM_DEFINE (scm_load_thunk_from_memory, "load-thunk-from-memory", 1, 0, 0,
-           (SCM bv),
+           (SCM obj),
            "")
 #define FUNC_NAME s_scm_load_thunk_from_memory
 {
   char *data;
   size_t len;
+  SCM bv, constants;
 
-  SCM_VALIDATE_BYTEVECTOR (1, bv);
+  SCM_VALIDATE_CONS (1, obj);
+  bv = scm_car (obj);
+  constants = scm_cdr (obj);
+  SCM_ASSERT (scm_is_bytevector (bv)
+              && (scm_is_vector (constants) || scm_is_false (constants)),
+              obj, 1, FUNC_NAME);
 
   data = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
   len = SCM_BYTEVECTOR_LENGTH (bv);
@@ -574,7 +585,7 @@ SCM_DEFINE (scm_load_thunk_from_memory, 
"load-thunk-from-memory", 1, 0, 0,
 
   data = copy_and_align_elf_data (data, len);
 
-  return load_thunk_from_memory (data, len, 0);
+  return load_thunk_from_memory (data, len, 0, constants);
 }
 #undef FUNC_NAME
 
diff --git a/module/language/bytecode/spec.scm 
b/module/language/bytecode/spec.scm
index 89256c5..d368f6e 100644
--- a/module/language/bytecode/spec.scm
+++ b/module/language/bytecode/spec.scm
@@ -37,6 +37,7 @@
 (define-language bytecode
   #:title      "Bytecode"
   #:compilers   `((value . ,bytecode->value))
-  #:printer    (lambda (bytecode port) (put-bytevector port bytecode))
+  #:printer    (lambda (x port)
+                  (put-bytevector port (car x)))
   #:reader      get-bytevector-all
   #:for-humans? #f)
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 1cb85ad..b0f8e13 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -553,6 +553,24 @@
             env
             env)))
 
+(define (compile-bytecode exp env opts)
+  (define to-file? (kw-arg-ref opts #:to-file? #f))
+  ;; See comment in `optimize' about the use of set!.
+  (set! exp (fix-arities exp))
+  (set! exp (optimize exp opts))
+  (set! exp (convert-closures exp))
+  ;; first-order optimization should go here
+  (set! exp (reify-primitives exp))
+  (set! exp (renumber exp))
+  (let* ((asm (make-assembler)))
+    (match exp
+      (($ $program funs)
+       (for-each (lambda (fun) (compile-fun fun asm))
+                 funs)))
+    (values (link-assembly asm #:page-aligned? to-file?)
+            env
+            env)))
+
 (define (lower-cps exp opts)
   ;; FIXME: For now the closure conversion pass relies on $rec instances
   ;; being separated into SCCs.  We should fix this to not be the case,
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index e845863..8c4ea2f 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -494,7 +494,7 @@ Disassemble a compiled procedure."
     (cond
      ((program? obj)
       (disassemble-program obj))
-     ((bytevector? obj)
+     ((and (pair? obj) (bytevector? (car obj)))
       (disassemble-image (load-image obj)))
      (else
       (format #t
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 94ebf03..efc370a 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -368,7 +368,8 @@ N-byte unit."
             constants inits
             shstrtab next-section-number
             meta sources
-            slot-maps)
+            slot-maps
+            to-file?)
   asm?
 
   ;; We write bytecode into a bytevector, growing the bytevector as
@@ -440,10 +441,16 @@ N-byte unit."
   ;; relative to the beginning of the text section.  SLOT-MAP is a
   ;; bitfield describing the stack at call sites, as an integer.
   ;;
-  (slot-maps asm-slot-maps set-asm-slot-maps!))
+  (slot-maps asm-slot-maps set-asm-slot-maps!)
+
+  (to-file? asm-to-file?))
+
+(define-inline (fresh-block)
+  (make-u32vector *block-size*))
 
 (define* (make-assembler #:key (word-size (target-word-size))
-                         (endianness (target-endianness)))
+                         (endianness (target-endianness))
+                         (to-file? #t))
   "Create an assembler for a given target @var{word-size} and
 @var{endianness}, falling back to appropriate values for the configured
 target."
@@ -452,7 +459,7 @@ target."
             word-size endianness
             vlist-null '()
             (make-string-table) 1
-            '() '() '()))
+            '() '() '() to-file?))
 
 (define (intern-section-name! asm string)
   "Add a string to the section name table (shstrtab)."
@@ -1064,7 +1071,10 @@ table, its existing label is used directly."
      ((array? obj)
       `((static-patch! ,label 1 ,(recur (shared-array-root obj)))))
      (else
-      (error "don't know how to intern" obj))))
+      (if (asm-to-file? asm)
+          (error "don't know how to intern" obj)
+          `((vector-ref/immediate 1 0 ,(vlist-length (asm-constants asm)))
+            (static-set! 1 ,label 0))))))
   (cond
    ((immediate-bits asm obj) #f)
    ((vhash-assoc obj (asm-constants asm)) => cdr)
@@ -1350,7 +1360,10 @@ a procedure to do that and return its label.  Otherwise 
return
          (let ((label (gensym "init-constants")))
            (emit-text asm
                       `((begin-program ,label ())
-                        (assert-nargs-ee/locals 1 1)
+                        ,@(if (asm-to-file? asm)
+                              '((assert-nargs-ee/locals 1 1))
+                              '((assert-nargs-ee/locals 2 0)
+                                (mov 0 1)))
                         ,@(reverse inits)
                         (load-constant 0 ,*unspecified*)
                         (return-values 2)
@@ -1564,7 +1577,9 @@ should be .data or .rodata), and return the resulting 
linker object.
               (lp (+ pos (* 3 word-size)) (cdr bounds) (cdr incs))))))
 
        (else
-        (error "unrecognized object" obj))))
+        (if (asm-to-file? asm)
+            (error "unrecognized object" obj)
+            (write-constant-reference buf pos obj)))))
 
     (cond
      ((vlist-null? data) #f)
@@ -2556,4 +2571,7 @@ procedure with label @var{rw-init}.  @var{rw-init} may be 
false.  If
 The result is a bytevector, by default linked so that read-only and
 writable data are on separate pages.  Pass @code{#:page-aligned? #f} to
 disable this behavior."
-  (link-elf (link-objects asm) #:page-aligned? page-aligned?))
+  (define (asm-constant-vector asm)
+    (list->vector (reverse (map car (vlist->list (asm-constants asm))))))
+  (let ((bv (link-elf (link-objects asm) #:page-aligned? page-aligned?)))
+    (cons bv (if (asm-to-file? asm) #f (asm-constant-vector asm)))))