diff options
| -rw-r--r-- | libguile/loader.c | 23 | ||||
| -rw-r--r-- | module/language/bytecode/spec.scm | 3 | ||||
| -rw-r--r-- | module/language/cps/compile-bytecode.scm | 18 | ||||
| -rw-r--r-- | module/system/repl/command.scm | 2 | ||||
| -rw-r--r-- | module/system/vm/assembler.scm | 34 |
5 files changed, 64 insertions, 16 deletions
diff --git a/libguile/loader.c b/libguile/loader.c index 743c8b0cd..1534ff897 100644 --- a/libguile/loader.c +++ b/libguile/loader.c @@ -344,7 +344,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; @@ -466,7 +466,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); @@ -569,19 +574,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); @@ -591,7 +602,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/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index f6805f38d..dc3c2f5a5 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -592,6 +592,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 acb18e0a0..0fe1b4191 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 8d71dc551..7607c191b 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -386,7 +386,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 @@ -458,10 +459,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." @@ -470,7 +477,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)." @@ -1090,7 +1097,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) @@ -1377,7 +1387,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) @@ -1619,7 +1632,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) @@ -2611,4 +2626,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))))) |