mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
remove glil->objcode path in favor of passing through assembly; refactorings.
* module/language/assembly.scm: Refactor a bit; remove the name "code" from the API, as it's too generic, and replace with "assembly". * module/language/assembly/compile-bytecode.scm: Get byte lengths via, well, byte-length. * module/language/glil/Makefile.am: * module/language/glil/spec.scm: * module/language/glil/compile-objcode.scm: Remove compile-objcode, as we just go through bytecode now. * module/language/glil/compile-assembly.scm (glil->assembly) (dump-object): s/object->code/object->assembly/.
This commit is contained in:
Andy Wingo
parent
6f78702819
commit
4b31848284
6 changed files with 34 additions and 449 deletions
|
|
@ -22,33 +22,37 @@
|
|||
(define-module (language assembly)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (system vm instruction)
|
||||
#:export (byte-length code-pack code-unpack object->code code->object))
|
||||
#:export (byte-length
|
||||
assembly-pack assembly-unpack
|
||||
object->assembly assembly->object))
|
||||
|
||||
(define (len+ len)
|
||||
(+ 3 len))
|
||||
;; nargs, nrest, nlocs, nexts, len
|
||||
(define *program-header-len* (+ 1 1 1 1 4))
|
||||
|
||||
(define (byte-length x)
|
||||
(pmatch x
|
||||
;; lengths are encoded in 3 bytes
|
||||
(define *len-len* 3)
|
||||
|
||||
(define (byte-length assembly)
|
||||
(pmatch assembly
|
||||
(,label (guard (not (pair? label)))
|
||||
0)
|
||||
((load-integer ,str)
|
||||
(1+ (len+ (string-length str))))
|
||||
(+ 1 *len-len* (string-length str)))
|
||||
((load-number ,str)
|
||||
(1+ (len+ (string-length str))))
|
||||
(+ 1 *len-len* (string-length str)))
|
||||
((load-string ,str)
|
||||
(1+ (len+ (string-length str))))
|
||||
(+ 1 *len-len* (string-length str)))
|
||||
((load-symbol ,str)
|
||||
(1+ (len+ (string-length str))))
|
||||
(+ 1 *len-len* (string-length str)))
|
||||
((load-keyword ,str)
|
||||
(1+ (len+ (string-length str))))
|
||||
(+ 1 *len-len* (string-length str)))
|
||||
((define ,str)
|
||||
(1+ (len+ (string-length str))))
|
||||
(+ 1 *len-len* (string-length str)))
|
||||
((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code)
|
||||
;; lengths of nargs, nrest, nlocs, nexts, len, and code, respectively
|
||||
(1+ (+ 1 1 1 1 4 len)))
|
||||
(+ 1 *program-header-len* len))
|
||||
((,inst . _) (guard (>= (instruction-length inst) 0))
|
||||
(1+ (instruction-length inst)))
|
||||
(else (error "unknown instruction" x))))
|
||||
(+ 1 (instruction-length inst)))
|
||||
(else (error "unknown instruction" assembly))))
|
||||
|
||||
;;;
|
||||
;;; Code compress/decompression
|
||||
|
|
@ -61,11 +65,11 @@
|
|||
(define *expansions*
|
||||
(map (lambda (x) (cons (cdr x) (car x))) *abbreviations*))
|
||||
|
||||
(define (code-pack code)
|
||||
(define (assembly-pack code)
|
||||
(or (assoc-ref code *abbreviations*)
|
||||
code))
|
||||
|
||||
(define (code-unpack code)
|
||||
(define (assembly-unpack code)
|
||||
(or (assoc-ref code *expansions*)
|
||||
code))
|
||||
|
||||
|
|
@ -74,7 +78,7 @@
|
|||
;;; Encoder/decoder
|
||||
;;;
|
||||
|
||||
(define (object->code x)
|
||||
(define (object->assembly x)
|
||||
(cond ((eq? x #t) `(make-true))
|
||||
((eq? x #f) `(make-false))
|
||||
((null? x) `(make-eol))
|
||||
|
|
@ -88,7 +92,7 @@
|
|||
((char? x) `(make-char8 ,(char->integer x)))
|
||||
(else #f)))
|
||||
|
||||
(define (code->object code)
|
||||
(define (assembly->object code)
|
||||
(pmatch code
|
||||
((make-true) #t)
|
||||
((make-false) #f) ;; FIXME: Same as the `else' case!
|
||||
|
|
|
|||
|
|
@ -21,27 +21,26 @@
|
|||
|
||||
(define-module (language assembly compile-bytecode)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (language assembly)
|
||||
#:use-module (system vm instruction)
|
||||
#:use-module (srfi srfi-4)
|
||||
#:use-module ((srfi srfi-1) #:select (fold))
|
||||
#:export (compile-bytecode write-bytecode))
|
||||
|
||||
(define *program-header-len* 8)
|
||||
|
||||
(define (compile-bytecode assembly env . opts)
|
||||
(pmatch assembly
|
||||
((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code)
|
||||
(letrec ((v (make-u8vector (+ *program-header-len* len)))
|
||||
((load-program . _)
|
||||
;; the 1- and -1 are so that we drop the load-program byte
|
||||
(letrec ((v (make-u8vector (1- (byte-length assembly))))
|
||||
(i -1)
|
||||
(write-byte (lambda (b)
|
||||
;; drop the load-program byte
|
||||
(if (>= i 0) (u8vector-set! v i b))
|
||||
(set! i (1+ i))))
|
||||
(get-addr (lambda () i)))
|
||||
(write-bytecode assembly write-byte get-addr '())
|
||||
(if (not (= i (u8vector-length v)))
|
||||
(error "incorrect length in assembly" i len))
|
||||
(values v env)))
|
||||
(if (= i (u8vector-length v))
|
||||
(values v env)
|
||||
(error "incorrect length in assembly" i (u8vector-length v)))))
|
||||
(else (error "bad assembly" assembly))))
|
||||
|
||||
(define (write-bytecode asm write-byte get-addr labels)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
SOURCES = spec.scm compile-objcode.scm compile-assembly.scm
|
||||
SOURCES = spec.scm compile-assembly.scm
|
||||
modpath = language/glil
|
||||
include $(top_srcdir)/am/guilec
|
||||
|
|
|
|||
|
|
@ -210,7 +210,7 @@
|
|||
|
||||
((<glil-const> obj)
|
||||
(cond
|
||||
((object->code obj)
|
||||
((object->assembly obj)
|
||||
=> (lambda (code)
|
||||
(emit-code (list code))))
|
||||
((not object-alist)
|
||||
|
|
@ -318,7 +318,7 @@
|
|||
|
||||
(let dump ((x x))
|
||||
(cond
|
||||
((object->code x) => list)
|
||||
((object->assembly x) => list)
|
||||
((variable-cache-cell? x) (dump (variable-cache-cell-key x)))
|
||||
((subprogram? x) (subprogram-code x))
|
||||
((and (integer? x) (exact? x))
|
||||
|
|
|
|||
|
|
@ -1,412 +0,0 @@
|
|||
;;; Guile VM assembler
|
||||
|
||||
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (language glil compile-objcode)
|
||||
#:use-syntax (system base syntax)
|
||||
#:use-module (language glil)
|
||||
#:use-module (system vm instruction)
|
||||
#:use-module (system vm objcode)
|
||||
#:use-module ((system vm program) #:select (make-binding))
|
||||
#:use-module (system vm conv)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 common-list)
|
||||
#:use-module (srfi srfi-4)
|
||||
#:use-module ((srfi srfi-1) #:select (append-map))
|
||||
#:export (preprocess codegen compile-objcode))
|
||||
|
||||
(define (compile-objcode glil env . opts)
|
||||
(codegen (preprocess glil #f) #t))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Types
|
||||
;;;
|
||||
|
||||
(define-record <vm-asm> venv glil body)
|
||||
(define-record <venv> parent nexts closure?)
|
||||
;; key is either a symbol or the list (MODNAME SYM PUBLIC?)
|
||||
(define-record <vlink-now> key)
|
||||
(define-record <vlink-later> key)
|
||||
(define-record <vdefine> name)
|
||||
(define-record <bytespec> nargs nrest nlocs nexts bytes meta objs closure?)
|
||||
|
||||
|
||||
;;;
|
||||
;;; Stage 1: Preprocess
|
||||
;;;
|
||||
|
||||
(define (preprocess x e)
|
||||
(record-case x
|
||||
((<glil-program> nargs nrest nlocs nexts meta body)
|
||||
(let* ((venv (make-venv #:parent e #:nexts nexts #:closure? #f))
|
||||
(body (map (lambda (x) (preprocess x venv)) body)))
|
||||
(make-vm-asm #:venv venv #:glil x #:body body)))
|
||||
((<glil-external> op depth index)
|
||||
(do ((d depth (- d 1))
|
||||
(e e (venv-parent e)))
|
||||
((= d 0))
|
||||
(set! (venv-closure? e) #t))
|
||||
x)
|
||||
(else x)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Stage 2: Bytecode generation
|
||||
;;;
|
||||
|
||||
(define-macro (push x loc)
|
||||
`(set! ,loc (cons ,x ,loc)))
|
||||
(define-macro (pop loc)
|
||||
`(let ((_x (car ,loc))) (set! ,loc (cdr ,loc)) _x))
|
||||
|
||||
;; this is to avoid glil-const's desire to put constants in the object
|
||||
;; array -- instead we explicitly want them in the code, because meta
|
||||
;; info is infrequently used. to load it up always would make garbage,
|
||||
;; needlessly. so hide it behind a lambda.
|
||||
(define (make-meta bindings sources tail)
|
||||
(if (and (null? bindings) (null? sources) (null? tail))
|
||||
#f
|
||||
(let ((stack '()))
|
||||
(define (push-code! code)
|
||||
(push (code->bytes code) stack))
|
||||
(dump-object! push-code! `(,bindings ,sources ,@tail))
|
||||
(push-code! '(return))
|
||||
(make-bytespec #:nargs 0 #:nrest 0 #:nlocs 0 #:nexts 0
|
||||
#:bytes (stack->bytes (reverse! stack) '())
|
||||
#:meta #f #:objs #f #:closure? #f))))
|
||||
|
||||
(define (byte-length x)
|
||||
(cond ((u8vector? x) (u8vector-length x))
|
||||
((>= (instruction-length (car x)) 0)
|
||||
;; one byte for the instruction itself
|
||||
(1+ (instruction-length (car x))))
|
||||
(else (error "variable-length instruction?" x))))
|
||||
|
||||
;; a binding that doesn't yet know its extents
|
||||
(define (make-temp-binding name ext? index)
|
||||
(list name ext? index))
|
||||
(define btemp:name car)
|
||||
(define btemp:extp cadr)
|
||||
(define btemp:index caddr)
|
||||
|
||||
(define (codegen glil toplevel)
|
||||
(record-case glil
|
||||
((<vm-asm> venv glil body) (record-case glil ((<glil-program> nargs nrest nlocs nexts meta) ; body?
|
||||
(let ((stack '())
|
||||
(open-bindings '())
|
||||
(closed-bindings '())
|
||||
(source-alist '())
|
||||
(label-alist '())
|
||||
;; the pre-elements are prepended to the object vector in
|
||||
;; practice these are placeholders for module & meta,
|
||||
;; respectively.
|
||||
(object-pre-elements '(#f #f))
|
||||
(object-alist '()))
|
||||
(define (object-index obj)
|
||||
(cond ((object-assoc obj object-alist) => cdr)
|
||||
(else
|
||||
(let ((i (+ (length object-alist) (length object-pre-elements))))
|
||||
(set! object-alist (acons obj i object-alist))
|
||||
i))))
|
||||
(define (push-code! code)
|
||||
; (format #t "push-code! ~a~%" code)
|
||||
(push (code->bytes code) stack))
|
||||
(define (push-object! x)
|
||||
(cond ((object->code x) => push-code!)
|
||||
(toplevel
|
||||
(dump-object! push-code! x))
|
||||
(else
|
||||
(push-code! `(object-ref ,(object-index x))))))
|
||||
(define (munge-bindings bindings nargs)
|
||||
(map
|
||||
(lambda (v)
|
||||
(let ((name (car v)) (type (cadr v)) (i (caddr v)))
|
||||
(case type
|
||||
((argument) (make-temp-binding name #f i))
|
||||
((local) (make-temp-binding name #f (+ nargs i)))
|
||||
((external) (make-temp-binding name #t i))
|
||||
(else (error "unknown binding type" name type)))))
|
||||
bindings))
|
||||
(define (push-bindings! bindings)
|
||||
(push (cons (current-address) bindings) open-bindings))
|
||||
(define (close-binding!)
|
||||
(let* ((bindings (pop open-bindings))
|
||||
(start (car bindings))
|
||||
(end (current-address)))
|
||||
(for-each
|
||||
(lambda (open)
|
||||
;; the cons is for dsu sort
|
||||
(push (cons start
|
||||
(make-binding (btemp:name open) (btemp:extp open)
|
||||
(btemp:index open) start end))
|
||||
closed-bindings))
|
||||
(cdr bindings))))
|
||||
(define (finish-bindings!)
|
||||
(while (not (null? open-bindings)) (close-binding!))
|
||||
(set! closed-bindings
|
||||
(stable-sort! (reverse! closed-bindings)
|
||||
(lambda (x y) (< (car x) (car y)))))
|
||||
(set! closed-bindings (map cdr closed-bindings)))
|
||||
(define (current-address)
|
||||
(apply + (map byte-length stack)))
|
||||
(define (generate-code x)
|
||||
(record-case x
|
||||
((<vm-asm> venv)
|
||||
(push-object! (codegen x #f))
|
||||
(if (venv-closure? venv) (push-code! `(make-closure))))
|
||||
|
||||
((<glil-bind> vars)
|
||||
(push-bindings! (munge-bindings vars nargs)))
|
||||
|
||||
((<glil-mv-bind> vars rest)
|
||||
(push-bindings! (munge-bindings vars nargs))
|
||||
(push-code! `(truncate-values ,(length vars) ,(if rest 1 0))))
|
||||
|
||||
((<glil-unbind>)
|
||||
(close-binding!))
|
||||
|
||||
((<glil-source> loc)
|
||||
(set! source-alist (acons (current-address) loc source-alist)))
|
||||
|
||||
((<glil-void>)
|
||||
(push-code! '(void)))
|
||||
|
||||
((<glil-const> obj)
|
||||
(push-object! obj))
|
||||
|
||||
((<glil-argument> op index)
|
||||
(if (eq? op 'ref)
|
||||
(push-code! `(local-ref ,index))
|
||||
(push-code! `(local-set ,index))))
|
||||
|
||||
((<glil-local> op index)
|
||||
(if (eq? op 'ref)
|
||||
(push-code! `(local-ref ,(+ nargs index)))
|
||||
(push-code! `(local-set ,(+ nargs index)))))
|
||||
|
||||
((<glil-external> op depth index)
|
||||
(do ((e venv (venv-parent e))
|
||||
(d depth (1- d))
|
||||
(n 0 (+ n (venv-nexts e))))
|
||||
((= d 0)
|
||||
(if (eq? op 'ref)
|
||||
(push-code! `(external-ref ,(+ n index)))
|
||||
(push-code! `(external-set ,(+ n index)))))))
|
||||
|
||||
((<glil-toplevel> op name)
|
||||
(case op
|
||||
((ref set)
|
||||
(cond
|
||||
(toplevel
|
||||
(push-object! (make-vlink-now #:key name))
|
||||
(push-code! (case op
|
||||
((ref) '(variable-ref))
|
||||
((set) '(variable-set)))))
|
||||
(else
|
||||
(let* ((var (make-vlink-later #:key name))
|
||||
(i (object-index var)))
|
||||
(push-code! (case op
|
||||
((ref) `(toplevel-ref ,i))
|
||||
((set) `(toplevel-set ,i))))))))
|
||||
((define)
|
||||
(push-object! (make-vdefine #:name name))
|
||||
(push-code! '(variable-set)))
|
||||
(else
|
||||
(error "unknown toplevel var kind" op name))))
|
||||
|
||||
((<glil-module> op mod name public?)
|
||||
(let ((key (list mod name public?)))
|
||||
(case op
|
||||
((ref set)
|
||||
(cond
|
||||
(toplevel
|
||||
(push-object! (make-vlink-now #:key key))
|
||||
(push-code! (case op
|
||||
((ref) '(variable-ref))
|
||||
((set) '(variable-set)))))
|
||||
(else
|
||||
(let* ((var (make-vlink-later #:key key))
|
||||
(i (object-index var)))
|
||||
(push-code! (case op
|
||||
((ref) `(toplevel-ref ,i))
|
||||
((set) `(toplevel-set ,i))))))))
|
||||
(else
|
||||
(error "unknown module var kind" op key)))))
|
||||
|
||||
((<glil-label> label)
|
||||
(set! label-alist (assq-set! label-alist label (current-address))))
|
||||
|
||||
((<glil-branch> inst label)
|
||||
(push (list inst label) stack))
|
||||
|
||||
((<glil-call> inst nargs)
|
||||
(if (instruction? inst)
|
||||
(let ((pops (instruction-pops inst)))
|
||||
(cond ((< pops 0)
|
||||
(push-code! (list inst nargs)))
|
||||
((= pops nargs)
|
||||
(push-code! (list inst)))
|
||||
(else
|
||||
(error "Wrong number of arguments:" inst nargs))))
|
||||
(error "Unknown instruction:" inst)))
|
||||
|
||||
((<glil-mv-call> nargs ra)
|
||||
(push (list 'mv-call nargs ra) stack))))
|
||||
|
||||
;;
|
||||
;; main
|
||||
(for-each generate-code body)
|
||||
(finish-bindings!)
|
||||
; (format #t "codegen: stack = ~a~%" (reverse stack))
|
||||
(let ((bytes (stack->bytes (reverse! stack) label-alist)))
|
||||
(if toplevel
|
||||
(bytecode->objcode bytes nlocs nexts)
|
||||
(let ((metathunk (make-meta closed-bindings
|
||||
(reverse! source-alist)
|
||||
meta)))
|
||||
(make-bytespec #:nargs nargs #:nrest nrest #:nlocs nlocs
|
||||
#:nexts nexts #:bytes bytes
|
||||
#:meta metathunk
|
||||
#:objs (if (and (null? object-alist) (not metathunk))
|
||||
#f
|
||||
(list->vector
|
||||
(append object-pre-elements
|
||||
(map car (reverse! object-alist)))))
|
||||
#:closure? (venv-closure? venv)))))))))))
|
||||
|
||||
(define (object-assoc x alist)
|
||||
(record-case x
|
||||
((<vlink-now>) (assoc x alist))
|
||||
((<vlink-later>) (assoc x alist))
|
||||
(else (assq x alist))))
|
||||
|
||||
(define (check-length len u8v)
|
||||
(or (= len (u8vector-length u8v))
|
||||
(error "the badness!" len u8v))
|
||||
u8v)
|
||||
|
||||
(define (stack->bytes stack label-alist)
|
||||
(let loop ((result '()) (stack stack) (addr 0))
|
||||
(if (null? stack)
|
||||
(check-length
|
||||
addr
|
||||
(list->u8vector
|
||||
(append-map u8vector->list (reverse! result))))
|
||||
(let ((elt (car stack)))
|
||||
(cond
|
||||
((u8vector? elt)
|
||||
(loop (cons elt result)
|
||||
(cdr stack)
|
||||
(+ addr (byte-length elt))))
|
||||
((symbol? (car (last-pair elt)))
|
||||
;; not yet code because labels needed to be resolved
|
||||
(let* ((head (list-head elt (1- (length elt))))
|
||||
(label-addr (assq-ref label-alist (car (last-pair elt))))
|
||||
(offset (- label-addr (+ addr (byte-length elt))))
|
||||
(n (if (< offset 0) (+ offset 65536) offset)))
|
||||
(loop (cons (code->bytes
|
||||
(append head (list (quotient n 256) (modulo n 256))))
|
||||
result)
|
||||
(cdr stack)
|
||||
(+ addr (byte-length elt)))))
|
||||
(else (error "bad code" elt)))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Object dump
|
||||
;;;
|
||||
|
||||
;; NOTE: undumpped in vm_system.c
|
||||
|
||||
(define (dump-object! push-code! x)
|
||||
(define (too-long x)
|
||||
(error (string-append x " too long")))
|
||||
|
||||
(let dump! ((x x))
|
||||
(cond
|
||||
((object->code x) => push-code!)
|
||||
((record? x)
|
||||
(record-case x
|
||||
((<bytespec> nargs nrest nlocs nexts bytes meta objs closure?)
|
||||
;; dump parameters
|
||||
(cond
|
||||
((and (< nargs 16) (< nlocs 128) (< nexts 16))
|
||||
;; 16-bit representation
|
||||
(let ((x (logior
|
||||
(ash nargs 12) (ash nrest 11) (ash nlocs 4) nexts)))
|
||||
(push-code! `(make-int16 ,(ash x -8) ,(logand x (1- (ash 1 8)))))))
|
||||
(else
|
||||
;; Other cases
|
||||
(if (> (+ nargs nlocs) 255)
|
||||
(error "too many locals" nargs nlocs))
|
||||
;; really it should be a flag..
|
||||
(if (> nrest 1) (error "nrest should be 0 or 1" nrest))
|
||||
(if (> nexts 255) (error "too many externals" nexts))
|
||||
(push-code! (object->code nargs))
|
||||
(push-code! (object->code nrest))
|
||||
(push-code! (object->code nlocs))
|
||||
(push-code! (object->code nexts))
|
||||
(push-code! (object->code #f))))
|
||||
;; dump object table
|
||||
(if objs (dump! objs))
|
||||
;; dump meta data
|
||||
(if meta (dump! meta))
|
||||
;; dump bytecode
|
||||
(push-code! `(load-program ,bytes)))
|
||||
((<vlink-later> key)
|
||||
(dump! key))
|
||||
((<vlink-now> key)
|
||||
(dump! key)
|
||||
(push-code! '(link-now)))
|
||||
((<vdefine> name)
|
||||
(push-code! `(define ,(symbol->string name))))
|
||||
(else
|
||||
(error "assemble: unknown record type" (record-type-descriptor x)))))
|
||||
((and (integer? x) (exact? x))
|
||||
(let ((str (do ((n x (quotient n 256))
|
||||
(l '() (cons (modulo n 256) l)))
|
||||
((= n 0)
|
||||
(apply u8vector l)))))
|
||||
(push-code! `(load-integer ,str))))
|
||||
((number? x)
|
||||
(push-code! `(load-number ,(number->string x))))
|
||||
((string? x)
|
||||
(push-code! `(load-string ,x)))
|
||||
((symbol? x)
|
||||
(push-code! `(load-symbol ,(symbol->string x))))
|
||||
((keyword? x)
|
||||
(push-code! `(load-keyword ,(symbol->string (keyword->symbol x)))))
|
||||
((list? x)
|
||||
(for-each dump! x)
|
||||
(let ((len (length x)))
|
||||
(if (>= len 65536) (too-long 'list))
|
||||
(push-code! `(list ,(quotient len 256) ,(modulo len 256)))))
|
||||
((pair? x)
|
||||
(dump! (car x))
|
||||
(dump! (cdr x))
|
||||
(push-code! `(cons)))
|
||||
((vector? x)
|
||||
(for-each dump! (vector->list x))
|
||||
(let ((len (vector-length x)))
|
||||
(if (>= len 65536) (too-long 'vector))
|
||||
(push-code! `(vector ,(quotient len 256) ,(modulo len 256)))))
|
||||
(else
|
||||
(error "assemble: unrecognized object" x)))))
|
||||
|
|
@ -21,19 +21,14 @@
|
|||
|
||||
(define-module (language glil spec)
|
||||
#:use-module (system base language)
|
||||
#:use-module (language objcode spec)
|
||||
#:use-module (language assembly spec)
|
||||
#:use-module (language glil)
|
||||
#:use-module (language glil compile-objcode)
|
||||
#:use-module (language glil compile-assembly)
|
||||
#:export (glil))
|
||||
|
||||
(define (write-glil exp . port)
|
||||
(apply write (unparse-glil exp) port))
|
||||
|
||||
(define (compile x e opts)
|
||||
(values (compile-objcode x e) e))
|
||||
|
||||
(define (compile-asm x e opts)
|
||||
(values (compile-assembly x) e))
|
||||
|
||||
|
|
@ -43,6 +38,5 @@
|
|||
#:reader read
|
||||
#:printer write-glil
|
||||
#:parser parse-glil
|
||||
#:compilers `((,assembly . ,compile-asm)
|
||||
(,objcode . ,compile))
|
||||
#:compilers `((,assembly . ,compile-asm))
|
||||
)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue