From 4e96211eb666751b8666beb918bf3108aa1c725b Mon Sep 17 00:00:00 2001 From: Robin Templeton Date: Tue, 10 Jun 2014 18:48:07 -0400 Subject: intern arbitrary constants (Best-ability ChangeLog annotation added by Christine Lemmer-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 : 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/system/repl/command.scm | 2 +- module/system/vm/assembler.scm | 33 ++++++++++++++++++++++++++------- 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))))) -- cgit v1.2.3