From: Andy Wingo Date: Sun, 18 Jan 2009 23:06:17 +0000 (+0100) Subject: add assembly intermediate language X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/f1d7723bb3ab0417bcfaf04647461fb0487c8cd4 add assembly intermediate language * configure.in: * module/language/Makefile.am: * module/language/assembly/Makefile.am: Automakery. * module/language/assembly.scm: * module/language/assembly/spec.scm: Add a new language, which is oddly even lower than GLIL. I got tired of GLIL's terrible compile-objcode.scm, and wanted a cleaner intermediate format. * module/language/glil/compile-assembly.scm: A purely-functional assembler, that produces "assembly". Will document later. * module/language/glil/spec.scm: Declare the compiler to assembly. --- diff --git a/configure.in b/configure.in index cd282b2ee..9af1090de 100644 --- a/configure.in +++ b/configure.in @@ -1558,6 +1558,7 @@ AC_CONFIG_FILES([ module/language/scheme/Makefile module/language/ghil/Makefile module/language/glil/Makefile + module/language/assembly/Makefile module/language/objcode/Makefile module/language/value/Makefile module/ice-9/Makefile diff --git a/module/language/Makefile.am b/module/language/Makefile.am index 7f179676e..33943acc5 100644 --- a/module/language/Makefile.am +++ b/module/language/Makefile.am @@ -1,4 +1,4 @@ -SUBDIRS=scheme ghil glil objcode value -SOURCES=ghil.scm glil.scm +SUBDIRS=scheme ghil glil assembly objcode value +SOURCES=ghil.scm glil.scm assembly.scm modpath = language include $(top_srcdir)/am/guilec diff --git a/module/language/assembly.scm b/module/language/assembly.scm new file mode 100644 index 000000000..baeba29a0 --- /dev/null +++ b/module/language/assembly.scm @@ -0,0 +1,49 @@ +;;; Guile Virtual Machine Assembly + +;; 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 assembly) + #:use-module (system base pmatch) + #:use-module (system vm instruction) + #:export (byte-length)) + +(define (byte-length x) + (pmatch x + (,label (guard (not (pair? label))) + 0) + ;; instructions take one byte, hence the 1+. + ((load-integer ,str) + (1+ (string-length str))) + ((load-number ,str) + (1+ (string-length str))) + ((load-string ,str) + (1+ (string-length str))) + ((load-symbol ,str) + (1+ (string-length str))) + ((load-keyword ,str) + (1+ (string-length str))) + ((define ,str) + (1+ (string-length str))) + ((assembly ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code) + ;; lengths of nargs, nrest, nlocs, nexts, len, and code, respectively + (+ 1 1 1 1 4 len)) + ((,inst . _) (guard (>= (instruction-length inst) 0)) + (1+ (instruction-length inst))) + (else (error "unknown instruction" x)))) diff --git a/module/language/assembly/Makefile.am b/module/language/assembly/Makefile.am new file mode 100644 index 000000000..ed3c1604d --- /dev/null +++ b/module/language/assembly/Makefile.am @@ -0,0 +1,3 @@ +SOURCES = spec.scm compile-objcode.scm +modpath = language/assembly +include $(top_srcdir)/am/guilec diff --git a/module/language/assembly/spec.scm b/module/language/assembly/spec.scm new file mode 100644 index 000000000..8eee64beb --- /dev/null +++ b/module/language/assembly/spec.scm @@ -0,0 +1,38 @@ +;;; Guile Virtual Machine Assembly + +;; 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 assembly spec) + #:use-module (system base language) + #:use-module (language objcode spec) + ;; #:use-module (language assembly compile-objcode) + #:export (assembly)) + +(define (compile x e opts) + (values (compile-objcode x e) e)) + +(define-language assembly + #:title "Guile Virtual Machine Assembly Language" + #:version "2.0" + #:reader read + #:printer write + #:parser read ;; fixme: make a verifier? + ;; #:compilers `((,objcode . ,compile)) + ) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm new file mode 100644 index 000000000..29c3d3fec --- /dev/null +++ b/module/language/glil/compile-assembly.scm @@ -0,0 +1,344 @@ +;;; 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-assembly) + #:use-module (system base syntax) + #:use-module (system base pmatch) + #:use-module (language glil) + #:use-module (language assembly) + #:use-module (system vm instruction) + #:use-module ((system vm program) #:select (make-binding)) + #:use-module (system vm conv) ;; fixme: move this module + #:use-module (ice-9 receive) + #:use-module ((srfi srfi-1) #:select (fold)) + #:export (compile-assembly)) + +;; Variable cache cells go in the object table, and serialize as their +;; keys. The reason we wrap the keys in these records is so they don't +;; compare as `equal?' to other objects in the object table. +;; +;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?) + +(define-record key) + +;; Subprograms can be loaded into an object table as well. We need a +;; disjoint type here too. + +(define-record code) + + +;; A metadata thunk has no object table, so it is very quick to load. +(define (make-meta bindings sources tail) + (if (and (null? bindings) (null? sources) (null? tail)) + #f + (make-subprogram + (compile-assembly + (make-glil-program 0 0 0 0 #f + (list + (make-glil-const `(,bindings ,sources ,@tail)) + (make-glil-call 'return 0))))))) + +;; A functional stack of names of live variables. +(define (make-open-binding name ext? index) + (list name ext? index)) +(define (make-closed-binding open-binding start end) + (make-binding (car open-binding) (cadr open-binding) + (caddr open-binding) start end)) +(define (open-binding bindings vars nargs start) + (cons + (acons start + (map + (lambda (v) + (pmatch v + ((,name argument ,i) (make-open-binding name #f i)) + ((,name local ,i) (make-open-binding name #f (+ nargs i))) + ((,name external ,i) (make-open-binding name #t i)) + (else (error "unknown binding type" name type)))) + vars) + (car bindings)) + (cdr bindings))) +(define (close-binding bindings end) + (pmatch bindings + ((((,start . ,closing) . ,open) . ,closed) + (cons open + (fold (lambda (o tail) + ;; the cons is for dsu sort + (acons start (make-closed-binding o start end) + tail)) + closed + closing))) + (else (error "broken bindings" bindings)))) +(define (close-all-bindings bindings end) + (if (null? (car bindings)) + (map cdr + (stable-sort (reverse (cdr bindings)) + (lambda (x y) (< (car x) (car y))))) + (close-all-bindings (close-binding bindings end) end))) + +;; A functional object table. +(define *module-and-meta* 2) +(define (assoc-ref-or-acons x alist make-y) + (cond ((assoc-ref x alist) + => (lambda (y) (values y alist))) + (else + (let ((y (make-y x alist))) + (values y (acons x y alist)))))) +(define (object-index-and-alist x alist) + (assoc-ref-or-acons x alist + (lambda (x alist) + (+ (length alist) *module-and-meta*)))) + +(define (compile-assembly glil) + (receive (code . _) + (glil->assembly glil 0 '() '(()) '() '() #f 0) + (car code))) +(define (make-object-table objects meta) + (and (or meta (not (null? objects))) + (list->vector (cons* #f meta objects)))) + +(define (glil->assembly glil nargs nexts-stack bindings + source-alist label-alist object-alist addr) + (define (emit-code x) + (values x bindings source-alist label-alist object-alist)) + (define (emit-code/object x object-alist) + (values x bindings source-alist label-alist object-alist)) + + (record-case glil + (( nargs nrest nlocs nexts meta body) + (define (process-body) + (let ((nexts-stack (cons nexts nexts-stack))) + (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) + (label-alist '()) (object-alist (if (null? (cdr nexts-stack)) #f '())) (addr 0)) + (cond + ((null? body) + (values (reverse code) + (close-all-bindings bindings addr) + (reverse source-alist) + (reverse label-alist) + (and object-alist (map car (reverse object-alist))) + addr)) + (else + (receive (subcode bindings source-alist label-alist object-alist) + (glil->assembly (car body) nargs nexts-stack bindings + source-alist label-alist object-alist addr) + (lp (cdr body) (append (reverse subcode) code) + bindings source-alist label-alist object-alist + (apply + addr (map byte-length subcode))))))))) + + ;; include len and labels + (receive (code bindings sources labels objects subaddr) + (process-body) + (let ((asm `(,@(if objects + (dump-object + (make-object-table objects + (make-meta bindings sources meta)) + addr) + '()) + (assembly ,nargs ,nrest ,nlocs ,nexts + ,labels ,subaddr + . ,code) + ,@(if closure? '((make-closure)) '())))) + (cond ((or (null? nexts-stack) (not object-alist)) + (emit-code asm)) + (else + (receive (i object-alist) + (object-index-and-alist (make-subprogram asm) object-alist) + (emit-code/object '((object-ref ,i)) object-alist))))))) + + (( vars) + (values '() + (open-binding bindings vars nargs addr) + source-alist + label-alist + object-alist)) + + (( vars rest) + (values `((truncate-values ,(length vars) ,(if rest 1 0))) + (open-binding bindings vars nargs addr) + source-alist + label-alist + object-alist)) + + (() + (values '() + (close-binding bindings addr) + source-alist + label-alist + object-alist)) + + (( loc) + (values '() + bindings + (acons addr loc source-alist) + label-alist + object-alist)) + + (() + (emit-code '((void)))) + + (( obj) + (cond + ((object->code obj) + => (lambda (code) + (emit-code (list code)))) + ((not object-alist) + (emit-code (dump-object obj addr))) + (else + (receive (i object-alist) + (object-index-and-alist obj object-alist) + (emit-code/object `((object-ref ,i)) + object-alist))))) + + (( op index) + (emit-code (if (eq? op 'ref) + `((local-ref ,index)) + `((local-set ,index))))) + + (( op index) + (emit-code (if (eq? op 'ref) + `((local-ref ,(+ nargs index))) + `((local-set ,(+ nargs index)))))) + + (( op depth index) + (emit-code (let lp ((d depth) (n 0) (stack nexts-stack)) + (if (> d 0) + (lp (1- d) (+ n (car stack)) (cdr stack)) + (if (eq? op 'ref) + `((external-ref ,(+ n index))) + `((external-set ,(+ n index)))))))) + + (( op name) + (case op + ((ref set) + (cond + ((not object-alist) + (emit-code `(,@(dump-object name addr) + (link-now) + ,(case op + ((ref) '(variable-ref)) + ((set) '(variable-set)))))) + (else + (receive (i object-alist) + (object-index-and-alist (make-variable-cache-cell name) + object-alist) + (emit-code/object (case op + ((ref) `((toplevel-ref ,i))) + ((set) `((toplevel-set ,i)))) + object-alist))))) + ((define) + (emit-code `((define ,(symbol->string name)) + (variable-set)))) + (else + (error "unknown toplevel var kind" op name)))) + + (( op mod name public?) + (let ((key (list mod name public?))) + (case op + ((ref set) + (cond + ((not object-alist) + (emit-code `(,@(dump-object key addr) + (link-now) + ,(case op + ((ref) '(variable-ref)) + ((set) '(variable-set)))))) + (else + (receive (i object-alist) + (object-index-and-alist (make-variable-cache-cell name) + object-alist) + (emit-code/object (case op + ((ref) `((toplevel-ref ,i))) + ((set) `((toplevel-set ,i)))) + object-alist))))) + (else + (error "unknown module var kind" op key))))) + + (( label) + (values '() + bindings + source-alist + (acons label addr label-alist) + object-alist)) + + (( inst label) + (emit-code `((,inst ,label)))) + + ;; nargs is number of stack args to insn. probably should rename. + (( inst nargs) + (if (not (instruction? inst)) + (error "Unknown instruction:" inst)) + (let ((pops (instruction-pops inst))) + (cond ((< pops 0) + (emit-code `((,inst ,nargs)))) + ((= pops nargs) + (emit-code `((,inst)))) + (else + (error "Wrong number of stack arguments to instruction:" inst nargs))))) + + (( nargs ra) + (emit-code `((mv-call ,nargs ,ra)))))) + +;; addr is currently unused, but could be used to align data in the +;; instruction stream. +(define (dump-object x addr) + (define (too-long x) + (error (string-append x " too long"))) + + (let dump ((x x)) + (cond + ((object->code x) => list) + ((variable-cache-cell? x) (dump (variable-cache-cell-key x))) + ((subprogram? x) (list (subprogram-code 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))))) + `((load-integer ,str)))) + ((number? x) + `((load-number ,(number->string x)))) + ((string? x) + `((load-string ,x))) + ((symbol? x) + `((load-symbol ,(symbol->string x)))) + ((keyword? x) + `((load-keyword ,(symbol->string (keyword->symbol x))))) + ((list? x) + (fold (lambda (x y) + (append (dump x) y)) + (let ((len (length x))) + (if (>= len 65536) (too-long "list")) + `((list ,(quotient len 256) ,(modulo len 256)))) + x)) + ((pair? x) + `(,@(dump (car x)) + ,@(dump (cdr x)) + (cons))) + ((vector? x) + (fold (lambda (x y) + (append (dump x) y)) + (let ((len (vector-length x))) + (if (>= len 65536) (too-long "vector")) + `((vector ,(quotient len 256) ,(modulo len 256)))) + (vector->list x))) + (else + (error "assemble: unrecognized object" x))))) + diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm index 58ed9baa2..c288c8f9b 100644 --- a/module/language/glil/spec.scm +++ b/module/language/glil/spec.scm @@ -22,8 +22,10 @@ (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) @@ -32,11 +34,15 @@ (define (compile x e opts) (values (compile-objcode x e) e)) +(define (compile-asm x e opts) + (values (compile-assembly x) e)) + (define-language glil #:title "Guile Lowlevel Intermediate Language (GLIL)" #:version "0.3" #:reader read #:printer write-glil #:parser parse-glil - #:compilers `((,objcode . ,compile)) + #:compilers `((,objcode . ,compile) + (,assembly . ,compile-asm)) )