mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

temp commit

Browse source
This commit is contained in:
Andy Wingo 2009-08-14 13:44:16 +02:00
parent 66ff15e2f0
commit 51b91fe141
4 changed files with 520 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

4
module/Makefile.am
View file

@ -89,7 +89,9 @@ GHIL_LANG_SOURCES = \
language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm
GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm \
language/glil/compile-assembly.scm \
language/glil/spec.scm \
language/glil/compile-sassy.scm \
language/glil/decompile-assembly.scm
ASSEMBLY_LANG_SOURCES = \

478
module/language/glil/compile-sassy.scm Normal file
View file

@ -0,0 +1,478 @@
;;; Guile x86-32 assembler
;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (language glil compile-sassy)
#: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 (ice-9 receive)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (rnrs bytevector)
#: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 <variable-cache-cell> key)
;; Subprograms can be loaded into an object table as well. We need a
;; disjoint type here too. (Subprograms have their own object tables --
;; though probably we should just make one table per compilation unit.)
(define-record <subprogram> table prog)
(define (limn-sources sources)
(let lp ((in sources) (out '()) (filename #f))
(if (null? in)
(reverse! out)
(let ((addr (caar in))
(new-filename (assq-ref (cdar in ) 'filename))
(line (assq-ref (cdar in) 'line))
(column (assq-ref (cdar in) 'column)))
(cond
((not (equal? new-filename filename))
(lp (cdr in)
`((,addr . (,line . ,column))
(filename . ,new-filename)
. ,out)
new-filename))
((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
(lp (cdr in)
`((,addr . (,line . ,column))
. ,out)
filename))
(else
(lp (cdr in) out filename)))))))
(define (make-meta bindings sources tail)
(if (and (null? bindings) (null? sources) (null? tail))
#f
(compile-sassy
(make-glil-program 0 0 0 '()
(list
(make-glil-const `(,bindings ,sources ,@tail))
(make-glil-call 'return 1))))))
;; A functional stack of names of live variables.
(define (make-open-binding name boxed? index)
(list name boxed? 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 start)
(cons
(acons start
(map
(lambda (v)
(pmatch v
((,name ,boxed? ,i)
(make-open-binding name boxed? i))
(else (error "unknown binding type" v))))
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* 1)
(define (assoc-ref-or-acons alist x make-y)
(cond ((assoc-ref alist x)
=> (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 alist x
(lambda (x alist)
(+ (length alist) *module*))))
(define *true* #x104)
(define *false* #x4)
(define *null* #x404)
(define *fixnum-tag* #b10)
(define *fixnum-shift* 2)
(define *char-tag* #b00001100)
(define *char-shift* 8)
(define (compile-sassy glil)
(receive (code . _)
(glil->sassy glil #t '(()) '() #f)
(car code)))
(define (make-object-table objects)
(and (not (null? objects))
(list->vector (cons #f objects))))
(define (glil->sassy glil toplevel? bindings source-alist object-alist)
(define (emit-code x)
(values x bindings source-alist object-alist))
(define (emit-code/object x object-alist)
(values x bindings source-alist object-alist))
(record-case glil
((<glil-program> nargs nrest nlocs meta body)
(define (process-body)
(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
(object-alist (if toplevel? #f '())))
(cond
((null? body)
(values (reverse code)
(close-all-bindings bindings addr)
(limn-sources (reverse! source-alist))
(and object-alist (map car (reverse object-alist)))))
(else
(receive (subcode bindings source-alist object-alist)
(glil->assembly (car body) #f bindings source-alist object-alist)
(lp (cdr body) (append (reverse subcode) code)
bindings source-alist object-alist))))))
(receive (code bindings sources objects)
(process-body)
(let* ((meta (make-meta bindings sources meta))
(meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
(prog `(load-program ,nargs ,nrest ,nlocs ,labels
,(+ len meta-pad)
,meta
,@code
,@(if meta
(make-list meta-pad '(nop))
'()))))
(cond
(toplevel?
;; toplevel bytecode isn't loaded by the vm, no way to do
;; object table or closure capture (not in the bytecode,
;; anyway)
(emit-code (list prog)))
(else
(let ((table (make-object-table objects)))
(cond
(object-alist
;; if we are being compiled from something with an object
;; table, cache the program there
(receive (i object-alist)
(object-index-and-alist (make-subprogram table prog)
object-alist)
(emit-code/object `(,(if (< i 256)
`(object-ref ,i)
`(long-object-ref ,(quotient i 256)
,(modulo i 256))))
object-alist)))
(else
;; otherwise emit a load directly
(let ((table-code (dump-object table addr)))
(emit-code
`(,@table-code
,@(align-program prog (addr+ addr table-code)))))))))))))
((<glil-bind> vars)
(values '()
(open-binding bindings vars addr)
source-alist
object-alist))
((<glil-mv-bind> vars rest)
(values `((truncate-values ,(length vars) ,(if rest 1 0)))
(open-binding bindings vars addr)
source-alist
object-alist))
((<glil-unbind>)
(values '()
(close-binding bindings addr)
source-alist
object-alist))
((<glil-source> props)
(values '()
bindings
(acons addr props source-alist)
object-alist))
((<glil-void>)
(emit-code '((void))))
((<glil-const> obj)
(cond
((object->assembly 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 (if (< i 256)
`((object-ref ,i))
`((long-object-ref ,(quotient i 256)
,(modulo i 256))))
object-alist)))))
((<glil-lexical> local? boxed? op index)
(emit-code
(if local?
(if (< index 256)
(case op
((ref) (if boxed?
`((local-boxed-ref ,index))
`((local-ref ,index))))
((set) (if boxed?
`((local-boxed-set ,index))
`((local-set ,index))))
((box) `((box ,index)))
((empty-box) `((empty-box ,index)))
((fix) `((fix-closure 0 ,index)))
(else (error "what" op)))
(let ((a (quotient i 256))
(b (modulo i 256)))
`((,(case op
((ref)
(if boxed?
`((long-local-ref ,a ,b)
(variable-ref))
`((long-local-ref ,a ,b))))
((set)
(if boxed?
`((long-local-ref ,a ,b)
(variable-set))
`((long-local-set ,a ,b))))
((box)
`((make-variable)
(variable-set)
(long-local-set ,a ,b)))
((empty-box)
`((make-variable)
(long-local-set ,a ,b)))
((fix)
`((fix-closure ,a ,b)))
(else (error "what" op)))
,index))))
`((,(case op
((ref) (if boxed? 'free-boxed-ref 'free-ref))
((set) (if boxed? 'free-boxed-set (error "what." glil)))
(else (error "what" op)))
,index)))))
((<glil-toplevel> 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 (if (< i 256)
`((,(case op
((ref) 'toplevel-ref)
((set) 'toplevel-set))
,i))
`((,(case op
((ref) 'long-toplevel-ref)
((set) 'long-toplevel-set))
,(quotient i 256)
,(modulo i 256))))
object-alist)))))
((define)
(emit-code `(,@(dump-object name addr)
(define))))
(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
((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 key)
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)))))
((<glil-label> label)
(values `((label ,label))
bindings
source-alist
object-alist))
((<glil-branch> inst label)
(emit-code
(case inst
((br)
`((jmp ,label)))
((br-if)
`((pop eax)
(cmp eax ,*false*)
(jne ,label)))
((br-if-not)
`((pop eax)
(cmp eax ,*false*)
(je ,label)))
(else (error "unrecognized inst" inst)))))
;; nargs is number of stack args to insn. probably should rename.
((<glil-call> inst nargs)
;; verify the inst
(if (not (instruction? inst))
(error "Unknown instruction:" inst))
(let ((pops (instruction-pops inst)))
(cond ((< pops 0)
(case (instruction-length inst)
((1 2) #t)
(else (error "Unknown length for variable-arg instruction:"
inst (instruction-length inst)))))
((= pops nargs) #t)
(else
(error "Wrong number of stack arguments to instruction:" inst nargs))))
(emit-code
(case inst
((add)
`((locals (fix post)
(pop ebx)
(pop eax)
(add eax ebx)
(jno fix)
;;segfault
(mov eax 0)
(add eax (& eax))
(jmp post)
(label fix)
(sub eax ,*fixnum-tag*)
(label post)
(push eax)))))
(else
(error "unhandled instruction" inst))))
((<glil-mv-call> nargs ra)
(error "mv-call not yet supported"))))
(define (dump-object x)
(define (too-long x)
(error (string-append x " too long")))
(cond
((eq? x #t) `((push ,*true*)))
((eq? x #f) `((push ,*false*)))
((null? x) `((push ,*null*)))
((and (integer? x) (exact? x)
(<= most-negative-fixnum x) (<= x most-positive-fixnum))
`((push ,(logior (ash x *fixnum-shift*) *fixnum-tag*))))
((char? x)
`((push ,(logior (ash (char->integer x) *char-shift*) *char-tag*))))
((variable-cache-cell? x) (dump-object (variable-cache-cell-key x)))
((subprogram? x)
(let ((table-code ))
`(,@(dump-object (subprogram-table x))
,(subprogram-prog x))
))
((number? x)
`((load-number ,(number->string x))))
((string? x)
(case (string-width x)
((1) `((load-string ,x)))
((4) (align-code `(load-wide-string ,x) addr 4 4))
(else (error "bad string width" x))))
((symbol? x)
(let ((str (symbol->string x)))
(case (string-width str)
((1) `((load-symbol ,str)))
((4) `(,@(dump-object str addr)
(make-symbol)))
(else (error "bad string width" str)))))
((keyword? x)
`(,@(dump-object (keyword->symbol x) addr)
(make-keyword)))
((list? x)
(let ((tail (let ((len (length x)))
(if (>= len 65536) (too-long "list"))
`((list ,(quotient len 256) ,(modulo len 256))))))
(let dump-objects ((objects x) (codes '()) (addr addr))
(if (null? objects)
(fold append tail codes)
(let ((code (dump-object (car objects) addr)))
(dump-objects (cdr objects) (cons code codes)
(addr+ addr code)))))))
((pair? x)
(let ((kar (dump-object (car x) addr)))
`(,@kar
,@(dump-object (cdr x) (addr+ addr kar))
(cons))))
((vector? x)
(let* ((len (vector-length x))
(tail (if (>= len 65536)
(too-long "vector")
`((vector ,(quotient len 256) ,(modulo len 256))))))
(let dump-objects ((i 0) (codes '()) (addr addr))
(if (>= i len)
(fold append tail codes)
(let ((code (dump-object (vector-ref x i) addr)))
(dump-objects (1+ i) (cons code codes)
(addr+ addr code)))))))
((and (array? x) (symbol? (array-type x)))
(let* ((type (dump-object (array-type x) addr))
(shape (dump-object (array-shape x) (addr+ addr type))))
`(,@type
,@shape
,@(align-code
`(load-array ,(uniform-array->bytevector x))
(addr+ (addr+ addr type) shape)
8
4))))
(else
(error "assemble: unrecognized object" x))))

7
module/language/glil/spec.scm
View file

@ -1,6 +1,6 @@
;;; Guile Lowlevel Intermediate Language
;; Copyright (C) 2001 Free Software Foundation, Inc.
;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -23,6 +23,7 @@
#:use-module (language glil)
#:use-module (language glil compile-assembly)
#:use-module (language glil decompile-assembly)
#:use-module (language glil compile-sassy)
#:export (glil))
(define (write-glil exp . port)
@ -37,5 +38,7 @@
#:reader read
#:printer write-glil
#:parser parse-glil
#:compilers `((assembly . ,compile-asm))
#:compilers `((assembly . ,compile-asm)
(sassy . ,(lambda x e opts)
(values (compile-sassy x) e e)))
#:decompilers `((assembly . ,decompile-assembly)))

34
module/language/sassy/spec.scm Normal file
View file

@ -0,0 +1,34 @@
;;; Guile x86-32 Machine Assembly
;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (language sassy spec)
#:use-module (system base language)
; #:use-module (language sassy compile-elf)
#:export (assembly))
(define-language sassy
#:title "Guile x86-32 Assembly Language"
#:version "2.0"
#:reader read
#:printer write
#:parser read
; #:compilers `((bytecode . ,compile-bytecode))
; #:decompilers `((bytecode . ,decompile-bytecode))
)