summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/loader.c23
-rw-r--r--module/language/bytecode/spec.scm3
-rw-r--r--module/system/repl/command.scm2
-rw-r--r--module/system/vm/assembler.scm33
4 files changed, 46 insertions, 15 deletions
diff --git a/libguile/loader.c b/libguile/loader.c
index ae4e1e368..cf34bfc19 100644
--- a/libguile/loader.c
+++ b/libguile/loader.c
@@ -353,7 +353,7 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
#define ABORT(msg) do { err_msg = msg; errno = 0; 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;
@@ -477,7 +477,12 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only)
}
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);
@@ -580,19 +585,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);
@@ -602,7 +613,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 89256c5c2..d368f6e34 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/system/repl/command.scm b/module/system/repl/command.scm
index 0024fd165..3c1783e92 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -502,7 +502,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 be1b79e34..8868343d7 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -502,7 +502,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
@@ -583,10 +584,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."
@@ -595,7 +602,7 @@ target."
word-size endianness
vlist-null vlist-null
(make-string-table) 1
- '() '() '()))
+ '() '() '() to-file?))
(define (intern-section-name! asm string)
"Add a string to the section name table (shstrtab)."
@@ -1349,7 +1356,10 @@ table, its existing label is used directly."
((array? obj)
(patch! 1 (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)
@@ -1805,6 +1815,10 @@ a procedure to do that and return its label. Otherwise return
(and (not (vlist-null? inits))
(let ((label (gensym "init-constants")))
(emit-begin-program asm label '())
+ (if (asm-to-file? asm)
+ '((emit-assert-nargs-ee/locals asm 1 1))
+ '((emit-assert-nargs-ee/locals asm 2 0)
+ (mov 0 1)))
(emit-assert-nargs-ee/locals asm 1 1)
(let lp ((n (1- (vlist-length inits))))
(match (vlist-ref inits n)
@@ -2082,7 +2096,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)))))
(define (add-relocs obj pos relocs)
(match obj
@@ -3098,4 +3114,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)))))