#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;
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);
(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);
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
(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)
(compile-entry)))))
(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))
(($ $program funs)
(for-each (lambda (fun) (compile-fun fun asm))
funs)))
- (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
+ (values (link-assembly asm #:page-aligned? to-file?)
env
env)))
(cond
((program? obj)
(disassemble-program obj))
- ((bytevector? obj)
+ ((and (pair? obj) (bytevector? (car obj)))
(disassemble-image (load-image obj)))
(else
(format #t
constants inits
shstrtab next-section-number
meta sources
- dead-slot-maps)
+ dead-slot-maps
+ to-file?)
asm?
;; We write bytecode into what is logically a growable vector,
;; DEAD-SLOT-MAP is a bitfield of slots that are dead at call sites,
;; as an integer.
;;
- (dead-slot-maps asm-dead-slot-maps set-asm-dead-slot-maps!))
+ (dead-slot-maps asm-dead-slot-maps set-asm-dead-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."
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)."
((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? obj) #f)
((vhash-assoc obj (asm-constants asm)) => cdr)
(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 1 ,*unspecified*)
(return 1)
(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)
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)))))