[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-215-g6302
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-215-g63026c5 |
|
Date: |
Tue, 20 Aug 2013 20:13:52 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=63026c58cb99c32b29fd86cdb0924608a37b1f9f
The branch, wip-cps-bis has been updated
via 63026c58cb99c32b29fd86cdb0924608a37b1f9f (commit)
via c0ab19b92d2119bca74dbb6b37e423b4b25e3615 (commit)
via 904e99b71600fad00b69b7b026dc7f852d88b1b6 (commit)
from 3acf0b1018099908fe798762c71f6be96fcf85b7 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 63026c58cb99c32b29fd86cdb0924608a37b1f9f
Author: Andy Wingo <address@hidden>
Date: Tue Aug 20 22:13:04 2013 +0200
RTL compiles to ELF images without passing through s-expressions
* module/language/cps/compile-rtl.scm: Instead of emitting
s-expressions, emit instructions directly using the assembler
interfaces.
(compile-rtl): Link the assembly to a bytevector at the end. RTL is
an ELF image.
* module/language/rtl/spec.scm: Adapt printer to just write the
bytevector.
* module/system/vm/assembler.scm (define-assembler):
(define-macro-assembler): Export the assemblers.
* test-suite/tests/rtl-compilation.test (compile-via-rtl): Adapt to RTL
format change.
commit c0ab19b92d2119bca74dbb6b37e423b4b25e3615
Author: Andy Wingo <address@hidden>
Date: Tue Aug 20 22:08:25 2013 +0200
assembler: give proper permissions to .data section
* module/system/vm/assembler.scm (link-data): Give stringbufs the
"shared" flag already, so we don't attempt to set it at runtime. Give
.data sections the SHF_WRITE flag.
commit 904e99b71600fad00b69b7b026dc7f852d88b1b6
Author: Andy Wingo <address@hidden>
Date: Tue Aug 20 22:06:46 2013 +0200
compile-file adds #:to-disk? #t to opts
* module/system/base/compile.scm (compile-file): Pass #:to-disk? as an
option to indicate that the result will be being loaded from disk.
Perhaps a linker might want to page-align in that case.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps/compile-rtl.scm | 508 ++++++++++++++++-----------------
module/language/rtl/spec.scm | 5 +-
module/system/base/compile.scm | 3 +-
module/system/vm/assembler.scm | 34 ++-
test-suite/tests/rtl-compilation.test | 4 +-
5 files changed, 279 insertions(+), 275 deletions(-)
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index a693692..00d6bb1 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -32,6 +32,7 @@
#:use-module (language cps primitives)
#:use-module (language cps reify-primitives)
#:use-module (language cps slot-allocation)
+ #:use-module (system vm assembler)
#:export (compile-rtl))
;; TODO: Source info, local var names. Needs work in the linker and the
@@ -90,177 +91,68 @@
(_ (values))))
-(define (emit-rtl-sequence exp moves slots nlocals cont-table)
- (let ((rtl '()))
- (define (slot sym)
- (lookup-slot sym slots))
-
- (define (constant sym)
- (lookup-constant-value sym slots))
-
- (define (emit asm)
- (set! rtl (cons asm rtl)))
-
- (define (emit-rtl label k exp next-label)
- (define (maybe-mov dst src)
- (unless (= dst src)
- (emit `(mov ,dst ,src))))
-
- (define (maybe-jump label)
- (unless (eq? label next-label)
- (emit `(br ,label))))
-
- (define (maybe-load-constant slot src)
- (call-with-values (lambda ()
- (lookup-maybe-constant-value src slots))
- (lambda (has-const? val)
- (and has-const?
- (begin
- (emit `(load-constant ,slot ,val))
- #t)))))
-
- (define (emit-tail)
- ;; There are only three kinds of expressions in tail position:
- ;; tail calls, multiple-value returns, and single-value returns.
- (match exp
- (($ $call proc args)
- (for-each (match-lambda
- ((src . dst) (emit `(mov ,dst ,src))))
- (lookup-parallel-moves label moves))
- (let ((tail-slots (cdr (iota (1+ (length args))))))
- (for-each maybe-load-constant tail-slots args))
- (emit `(tail-call ,(1+ (length args)))))
- (($ $values args)
- (let ((tail-slots (cdr (iota (1+ (length args))))))
- (for-each (match-lambda
- ((src . dst) (emit `(mov ,dst ,src))))
- (lookup-parallel-moves label moves))
- (for-each maybe-load-constant tail-slots args))
- (emit `(reset-frame ,(1+ (length args))))
- (emit `(return-values)))
- (($ $primcall 'return (arg))
- (emit `(return ,(slot arg))))))
-
- (define (emit-val sym)
- (let ((dst (slot sym)))
- (match exp
- (($ $var sym)
- (maybe-mov dst (slot sym)))
- (($ $void)
- (when dst
- (emit `(load-constant ,dst ,*unspecified*))))
- (($ $const exp)
- (when dst
- (emit `(load-constant ,dst ,exp))))
- (($ $fun meta self () entries)
- (emit `(load-static-procedure ,dst ,self)))
- (($ $fun meta self free entries)
- (emit `(make-closure ,dst ,self ,(length free))))
- (($ $call proc args)
- (let ((proc-slot (lookup-call-proc-slot label slots))
- (nargs (length args)))
- (or (maybe-load-constant proc-slot proc)
- (maybe-mov proc-slot (slot proc)))
- (let lp ((n (1+ proc-slot)) (args args))
- (match args
- (()
- (emit `(call ,proc-slot ,(+ nargs 1)))
- (emit `(receive ,dst ,proc-slot ,nlocals)))
- ((arg . args)
- (or (maybe-load-constant n arg)
- (maybe-mov n (slot arg)))
- (lp (1+ n) args))))))
- (($ $primcall 'current-module)
- (emit `(current-module ,dst)))
- (($ $primcall 'cached-toplevel-box (scope name bound?))
- (emit `(cached-toplevel-box ,dst ,(constant scope) ,(constant
name)
- ,(constant bound?))))
- (($ $primcall 'cached-module-box (mod name public? bound?))
- (emit `(cached-module-box ,dst ,(constant mod) ,(constant name)
- ,(constant public?) ,(constant
bound?))))
- (($ $primcall 'resolve (name bound?))
- (emit `(resolve ,dst ,(constant bound?) ,(slot name))))
- (($ $primcall 'free-ref (closure idx))
- (emit `(free-ref ,dst ,(slot closure) ,(constant idx))))
- (($ $primcall name args)
- (let ((inst (prim-rtl-instruction name)))
- (emit `(,inst ,dst ,@(map slot args)))))
- (($ $values (arg))
- (or (maybe-load-constant dst arg)
- (maybe-mov dst (slot arg))))
- (($ $prompt escape? tag handler)
- (emit `(prompt ,escape? ,tag ,handler))))
- (maybe-jump k)))
-
- (define (emit-vals syms)
- (match exp
- (($ $primcall name args)
- (emit `(primcall/vals ,name ,@args)))
- (($ $values args)
+(define (emit-rtl-sequence asm exp moves slots nlocals cont-table)
+ (define (slot sym)
+ (lookup-slot sym slots))
+
+ (define (constant sym)
+ (lookup-constant-value sym slots))
+
+ (define (emit-rtl label k exp next-label)
+ (define (maybe-mov dst src)
+ (unless (= dst src)
+ (emit-mov asm dst src)))
+
+ (define (maybe-jump label)
+ (unless (eq? label next-label)
+ (emit-br asm label)))
+
+ (define (maybe-load-constant slot src)
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value src slots))
+ (lambda (has-const? val)
+ (and has-const?
+ (begin
+ (emit-load-constant asm slot val)
+ #t)))))
+
+ (define (emit-tail)
+ ;; There are only three kinds of expressions in tail position:
+ ;; tail calls, multiple-value returns, and single-value returns.
+ (match exp
+ (($ $call proc args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label moves))
+ (let ((tail-slots (cdr (iota (1+ (length args))))))
+ (for-each maybe-load-constant tail-slots args))
+ (emit-tail-call asm (1+ (length args))))
+ (($ $values args)
+ (let ((tail-slots (cdr (iota (1+ (length args))))))
(for-each (match-lambda
- ((src . dst) (emit `(mov ,dst ,src))))
+ ((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label moves))
- (for-each maybe-load-constant (map slot syms) args)))
- (maybe-jump k))
-
- (define (emit-seq)
- (match exp
- (($ $primcall 'cache-current-module! (sym scope))
- (emit `(cache-current-module! ,(slot sym) ,(constant scope))))
- (($ $primcall 'free-set! (closure idx value))
- (emit `(free-set! ,(slot closure) ,(slot value) ,(constant idx))))
- (($ $primcall 'box-set! (box value))
- (emit `(box-set! ,(slot box) ,(slot value))))
- (($ $primcall 'struct-set! (struct index value))
- (emit `(struct-set! ,(slot struct) ,(slot index) ,(slot value))))
- (($ $primcall 'vector-set! (vector index value))
- (emit `(vector-set ,(slot vector) ,(slot index) ,(slot value))))
- (($ $primcall 'set-car! (pair value))
- (emit `(set-car! ,(slot pair) ,(slot value))))
- (($ $primcall 'set-cdr! (pair value))
- (emit `(set-cdr! ,(slot pair) ,(slot value))))
- (($ $primcall 'define! (sym value))
- (emit `(define ,(slot sym) ,(slot value))))
- (($ $primcall name args)
- (emit `(primcall/seq ,name ,@args)))
- (($ $values ()) #f))
- (maybe-jump k))
-
- (define (emit-test kt kf)
- (define (unary op sym)
- (cond
- ((eq? kt next-label)
- (emit `(,op ,(slot sym) #t ,kf)))
- (else
- (emit `(,op ,(slot sym) #f ,kt))
- (maybe-jump kf))))
- (define (binary op a b)
- (cond
- ((eq? kt next-label)
- (emit `(,op ,(slot a) ,(slot b) #t ,kf)))
- (else
- (emit `(,op ,(slot a) ,(slot b) #f ,kt))
- (maybe-jump kf))))
- (match exp
- (($ $var sym) (unary 'br-if-true sym))
- (($ $primcall 'null? (a)) (unary 'br-if-null a))
- (($ $primcall 'nil? (a)) (unary 'br-if-nil a))
- (($ $primcall 'pair? (a)) (unary 'br-if-pair a))
- (($ $primcall 'struct? (a)) (unary 'br-if-struct a))
- (($ $primcall 'char? (a)) (unary 'br-if-char a))
- ;; Add TC7 tests here
- (($ $primcall 'eq? (a b)) (binary 'br-if-eq a b))
- (($ $primcall 'eq? (a b)) (binary 'br-if-eq a b))
- (($ $primcall 'eqv? (a b)) (binary 'br-if-eqv a b))
- (($ $primcall 'equal? (a b)) (binary 'br-if-equal a b))
- (($ $primcall '< (a b)) (binary 'br-if-< a b))
- (($ $primcall '<= (a b)) (binary 'br-if-<= a b))
- (($ $primcall '= (a b)) (binary 'br-if-= a b))
- (($ $primcall '>= (a b)) (binary 'br-if-<= b a))
- (($ $primcall '> (a b)) (binary 'br-if-< b a))))
-
- (define (emit-trunc nreq rest? k)
+ (for-each maybe-load-constant tail-slots args))
+ (emit-reset-frame asm (1+ (length args)))
+ (emit-return-values asm))
+ (($ $primcall 'return (arg))
+ (emit-return asm (slot arg)))))
+
+ (define (emit-val sym)
+ (let ((dst (slot sym)))
(match exp
+ (($ $var sym)
+ (maybe-mov dst (slot sym)))
+ (($ $void)
+ (when dst
+ (emit-load-constant asm dst *unspecified*)))
+ (($ $const exp)
+ (when dst
+ (emit-load-constant asm dst exp)))
+ (($ $fun meta self () entries)
+ (emit-load-static-procedure asm dst self))
+ (($ $fun meta self free entries)
+ (emit-make-closure asm dst self (length free)))
(($ $call proc args)
(let ((proc-slot (lookup-call-proc-slot label slots))
(nargs (length args)))
@@ -269,107 +161,205 @@
(let lp ((n (1+ proc-slot)) (args args))
(match args
(()
- (emit `(call ,proc-slot ,(+ nargs 1)))
- (emit `(receive-values ,proc-slot ,nreq))
- (when rest?
- (emit `(bind-rest ,(+ proc-slot 1 nreq))))
- (for-each (match-lambda
- ((src . dst) (emit `(mov ,dst ,src))))
- (lookup-parallel-moves label moves))
- (emit `(reset-frame ,nlocals)))
+ (emit-call asm proc-slot (+ nargs 1))
+ (emit-receive asm dst proc-slot nlocals))
((arg . args)
(or (maybe-load-constant n arg)
(maybe-mov n (slot arg)))
- (lp (1+ n) args)))))))
- (maybe-jump k))
-
- (match (lookup-cont k cont-table)
- (($ $ktail) (emit-tail))
- (($ $kargs (name) (sym)) (emit-val sym))
- (($ $kargs () ()) (emit-seq))
- (($ $kargs names syms) (emit-vals syms))
- (($ $kargs (name) (sym)) (emit-val sym))
- (($ $kif kt kf) (emit-test kt kf))
- (($ $ktrunc ($ $arity req () rest () #f) k)
- (emit-trunc (length req) (and rest #t) k))))
-
- (define (collect-exps k src cont tail)
- (define (find-exp k src term)
- (match term
- (($ $continue exp-k exp)
- (cons (list k src exp-k exp) tail))
- (($ $letk conts body)
- (find-exp k src body))))
- (match cont
- (($ $kargs names syms body)
- (find-exp k src body))
- (_ tail)))
-
- (let lp ((exps (reverse (fold-local-conts collect-exps '() exp))))
- (match exps
- (() (reverse rtl))
- (((k src exp-k exp) . exps)
- (let ((next-label (match exps
- (((k . _) . _) k)
- (() #f))))
- (emit `(label ,k))
- (emit-rtl k exp-k exp next-label)
- (lp exps)))))))
-
-(define (compile-fun f)
- (let ((rtl '()))
- (define (emit asm)
- (set! rtl (cons asm rtl)))
-
- (define (emit-fun-entry self entry alternate)
- (call-with-values (lambda () (allocate-slots self entry))
- (lambda (moves slots nlocals)
- (match entry
- (($ $cont k src
- ($ $kentry ($ $arity req opt rest kw allow-other-keys?)
- tail
- body))
- (let ((kw-indices (map (match-lambda
- ((key name sym)
- (cons key (lookup-slot sym slots))))
- kw)))
- (emit `(label ,k))
- (emit `(begin-kw-arity ,req ,opt ,rest
- ,kw-indices ,allow-other-keys?
- ,nlocals
- ,alternate))
- (for-each emit
- (emit-rtl-sequence body moves slots nlocals
- (build-local-cont-table entry)))
- (emit `(end-arity))))))))
-
- (define (emit-fun-entries self entries)
- (match entries
- ((entry . entries)
- (let ((alternate (match entries
- (($cont _ k) k)
- (() #f))))
- (emit-fun-entry self entry alternate)
- (when alternate
- (emit-fun-entries self entries))))))
-
- (match f
- ;; FIXME: We shouldn't use SELF as a label.
- (($ $fun meta self free entries)
- (emit `(begin-program ,self ,(or meta '())))
- (emit-fun-entries self entries)
- (emit `(end-program))
- (reverse rtl)))))
+ (lp (1+ n) args))))))
+ (($ $primcall 'current-module)
+ (emit-current-module asm dst))
+ (($ $primcall 'cached-toplevel-box (scope name bound?))
+ (emit-cached-toplevel-box asm dst (constant scope) (constant name)
+ (constant bound?)))
+ (($ $primcall 'cached-module-box (mod name public? bound?))
+ (emit-cached-module-box asm dst (constant mod) (constant name)
+ (constant public?) (constant bound?)))
+ (($ $primcall 'resolve (name bound?))
+ (emit-resolve asm dst (constant bound?) (slot name)))
+ (($ $primcall 'free-ref (closure idx))
+ (emit-free-ref asm dst (slot closure) (constant idx)))
+ (($ $primcall name args)
+ ;; FIXME: Inline all the cases.
+ (let ((inst (prim-rtl-instruction name)))
+ (emit-text asm `((,inst ,dst ,@(map slot args))))))
+ (($ $values (arg))
+ (or (maybe-load-constant dst arg)
+ (maybe-mov dst (slot arg))))
+ (($ $prompt escape? tag handler)
+ (emit-prompt asm escape? tag handler)))
+ (maybe-jump k)))
+
+ (define (emit-vals syms)
+ (match exp
+ (($ $primcall name args)
+ (error "unimplemented primcall in values context" name))
+ (($ $values args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label moves))
+ (for-each maybe-load-constant (map slot syms) args)))
+ (maybe-jump k))
+
+ (define (emit-seq)
+ (match exp
+ (($ $primcall 'cache-current-module! (sym scope))
+ (emit-cache-current-module! asm (slot sym) (constant scope)))
+ (($ $primcall 'free-set! (closure idx value))
+ (emit-free-set! asm (slot closure) (slot value) (constant idx)))
+ (($ $primcall 'box-set! (box value))
+ (emit-box-set! asm (slot box) (slot value)))
+ (($ $primcall 'struct-set! (struct index value))
+ (emit-struct-set! asm (slot struct) (slot index) (slot value)))
+ (($ $primcall 'vector-set! (vector index value))
+ (emit-vector-set asm (slot vector) (slot index) (slot value)))
+ (($ $primcall 'set-car! (pair value))
+ (emit-set-car! asm (slot pair) (slot value)))
+ (($ $primcall 'set-cdr! (pair value))
+ (emit-set-cdr! asm (slot pair) (slot value)))
+ (($ $primcall 'define! (sym value))
+ (emit-define asm (slot sym) (slot value)))
+ (($ $primcall name args)
+ (error "unhandled primcall in seq context" name))
+ (($ $values ()) #f))
+ (maybe-jump k))
+
+ (define (emit-test kt kf)
+ (define (unary op sym)
+ (cond
+ ((eq? kt next-label)
+ (op asm (slot sym) #t kf))
+ (else
+ (op asm (slot sym) #f kt)
+ (maybe-jump kf))))
+ (define (binary op a b)
+ (cond
+ ((eq? kt next-label)
+ (op asm (slot a) (slot b) #t kf))
+ (else
+ (op asm (slot a) (slot b) #f kt)
+ (maybe-jump kf))))
+ (match exp
+ (($ $var sym) (unary emit-br-if-true sym))
+ (($ $primcall 'null? (a)) (unary emit-br-if-null a))
+ (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
+ (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
+ (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
+ (($ $primcall 'char? (a)) (unary emit-br-if-char a))
+ ;; Add TC7 tests here
+ (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+ (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+ (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
+ (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
+ (($ $primcall '< (a b)) (binary emit-br-if-< a b))
+ (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
+ (($ $primcall '= (a b)) (binary emit-br-if-= a b))
+ (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
+ (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
+
+ (define (emit-trunc nreq rest? k)
+ (match exp
+ (($ $call proc args)
+ (let ((proc-slot (lookup-call-proc-slot label slots))
+ (nargs (length args)))
+ (or (maybe-load-constant proc-slot proc)
+ (maybe-mov proc-slot (slot proc)))
+ (let lp ((n (1+ proc-slot)) (args args))
+ (match args
+ (()
+ (emit-call asm proc-slot (+ nargs 1))
+ (emit-receive-values asm proc-slot nreq)
+ (when rest?
+ (emit-bind-rest asm (+ proc-slot 1 nreq)))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label moves))
+ (emit-reset-frame asm nlocals))
+ ((arg . args)
+ (or (maybe-load-constant n arg)
+ (maybe-mov n (slot arg)))
+ (lp (1+ n) args)))))))
+ (maybe-jump k))
+
+ (match (lookup-cont k cont-table)
+ (($ $ktail) (emit-tail))
+ (($ $kargs (name) (sym)) (emit-val sym))
+ (($ $kargs () ()) (emit-seq))
+ (($ $kargs names syms) (emit-vals syms))
+ (($ $kargs (name) (sym)) (emit-val sym))
+ (($ $kif kt kf) (emit-test kt kf))
+ (($ $ktrunc ($ $arity req () rest () #f) k)
+ (emit-trunc (length req) (and rest #t) k))))
+
+ (define (collect-exps k src cont tail)
+ (define (find-exp k src term)
+ (match term
+ (($ $continue exp-k exp)
+ (cons (list k src exp-k exp) tail))
+ (($ $letk conts body)
+ (find-exp k src body))))
+ (match cont
+ (($ $kargs names syms body)
+ (find-exp k src body))
+ (_ tail)))
+
+ (let lp ((exps (reverse (fold-local-conts collect-exps '() exp))))
+ (match exps
+ (() #t)
+ (((k src exp-k exp) . exps)
+ (let ((next-label (match exps
+ (((k . _) . _) k)
+ (() #f))))
+ (emit-label asm k)
+ (emit-rtl k exp-k exp next-label)
+ (lp exps))))))
+
+(define (compile-fun f asm)
+ (define (emit-fun-entry self entry alternate)
+ (call-with-values (lambda () (allocate-slots self entry))
+ (lambda (moves slots nlocals)
+ (match entry
+ (($ $cont k src
+ ($ $kentry ($ $arity req opt rest kw allow-other-keys?)
+ tail
+ body))
+ (let ((kw-indices (map (match-lambda
+ ((key name sym)
+ (cons key (lookup-slot sym slots))))
+ kw)))
+ (emit-label asm k)
+ (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
+ nlocals alternate)
+ (emit-rtl-sequence asm body moves slots nlocals
+ (build-local-cont-table entry))
+ (emit-end-arity asm)))))))
+
+ (define (emit-fun-entries self entries)
+ (match entries
+ ((entry . entries)
+ (let ((alternate (match entries
+ (($cont _ k) k)
+ (() #f))))
+ (emit-fun-entry self entry alternate)
+ (when alternate
+ (emit-fun-entries self entries))))))
+
+ (match f
+ ;; FIXME: We shouldn't use SELF as a label.
+ (($ $fun meta self free entries)
+ (emit-begin-program asm self (or meta '()))
+ (emit-fun-entries self entries)
+ (emit-end-program asm))))
(define (compile-rtl exp env opts)
(let* ((exp (fix-arities exp))
(exp (optimize exp opts))
(exp (convert-closures exp))
(exp (reify-primitives exp))
- (rtl '()))
+ (asm (make-assembler)))
(visit-funs (lambda (fun)
- (set! rtl (cons (compile-fun fun) rtl)))
+ (compile-fun fun asm))
exp)
- (values (fold append '() rtl)
+ (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
env
env)))
diff --git a/module/language/rtl/spec.scm b/module/language/rtl/spec.scm
index c403fe4..0a8c4ee 100644
--- a/module/language/rtl/spec.scm
+++ b/module/language/rtl/spec.scm
@@ -20,11 +20,12 @@
(define-module (language rtl spec)
#:use-module (system base language)
+ #:use-module (ice-9 binary-ports)
#:export (rtl))
(define-language rtl
#:title "Register Transfer Language"
#:compilers '()
- #:printer write
- #:reader read
+ #:printer (lambda (rtl port) (put-bytevector port rtl))
+ #:reader get-bytevector-all
#:for-humans? #f)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index c522b74..82d75c7 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -150,7 +150,8 @@
(call-with-output-file/atomic comp
(lambda (port)
((language-printer (ensure-language to))
- (read-and-compile in #:env env #:from from #:to to #:opts opts)
+ (read-and-compile in #:env env #:from from #:to to #:opts
+ (cons* #:to-file? #t opts))
port))
file)
comp)))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 2c46c3b..9c267fe 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -440,10 +440,12 @@ later by the linker."
(syntax-case x ()
((_ name opcode kind arg ...)
(with-syntax ((emit (id-append #'name #'emit- #'name)))
- #'(define emit
- (let ((emit (assembler name opcode arg ...)))
- (hashq-set! assemblers 'name emit)
- emit)))))))
+ #'(begin
+ (define emit
+ (let ((emit (assembler name opcode arg ...)))
+ (hashq-set! assemblers 'name emit)
+ emit))
+ (export emit)))))))
(define-syntax visit-opcodes
(lambda (x)
@@ -601,10 +603,12 @@ returned instead."
(syntax-case x ()
((_ (name arg ...) body body* ...)
(with-syntax ((emit (id-append #'name #'emit- #'name)))
- #'(define emit
- (let ((emit (lambda (arg ...) body body* ...)))
- (hashq-set! assemblers 'name emit)
- emit)))))))
+ #'(begin
+ (define emit
+ (let ((emit (lambda (arg ...) body body* ...)))
+ (hashq-set! assemblers 'name emit)
+ emit))
+ (export emit)))))))
(define-macro-assembler (load-constant asm dst obj)
(cond
@@ -801,8 +805,13 @@ should be .data or .rodata), and return the resulting
linker object.
(modulo (- alignment (modulo address alignment)) alignment)))
(define tc7-vector 13)
- (define tc7-narrow-stringbuf 39)
- (define tc7-wide-stringbuf (+ 39 #x400))
+ (define stringbuf-shared-flag #x100)
+ (define stringbuf-wide-flag #x400)
+ (define tc7-stringbuf 39)
+ (define tc7-narrow-stringbuf
+ (+ tc7-stringbuf stringbuf-shared-flag))
+ (define tc7-wide-stringbuf
+ (+ tc7-stringbuf stringbuf-shared-flag stringbuf-wide-flag))
(define tc7-ro-string (+ 21 #x200))
(define tc7-rtl-program 69)
@@ -941,7 +950,10 @@ should be .data or .rodata), and return the resulting
linker object.
(lp (1+ i)
(align (+ (byte-length obj) pos) 8)
(cons (make-linker-symbol obj-label pos) labels)))
- (make-object asm name buf '() labels))))))))
+ (make-object asm name buf '() labels
+ #:flags (match name
+ ('.data (logior SHF_ALLOC SHF_WRITE))
+ ('.rodata SHF_ALLOC))))))))))
(define (link-constants asm)
"Link sections to hold constants needed by the program text emitted
diff --git a/test-suite/tests/rtl-compilation.test
b/test-suite/tests/rtl-compilation.test
index b0cd58f..0b1e283 100644
--- a/test-suite/tests/rtl-compilation.test
+++ b/test-suite/tests/rtl-compilation.test
@@ -19,10 +19,10 @@
(define-module (test-suite rtl-compilation)
#:use-module (test-suite lib)
#:use-module (system base compile)
- #:use-module (system vm assembler))
+ #:use-module (system vm objcode))
(define* (compile-via-rtl exp #:key peval? cse? (env (make-fresh-user-module)))
- (assemble-program
+ (load-thunk-from-memory
(compile exp #:env env #:to 'rtl
#:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-215-g63026c5,
Andy Wingo <=