mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 00:30:21 +02:00
Code Activity

Merge branch 'master' of git://git.savannah.gnu.org/guile into elisp

Browse source
This commit is contained in:
Daniel Kraft 2009-07-31 17:18:34 +02:00
commit a43df0ae47
42 changed files with 1767 additions and 1099 deletions
Download patch file Download diff file Expand all files Collapse all files

1
module/Makefile.am
View file

@ -34,6 +34,7 @@ SOURCES = \
ice-9/psyntax-pp.scm \
system/base/pmatch.scm system/base/syntax.scm \
system/base/compile.scm system/base/language.scm \
system/base/message.scm \
\
language/tree-il.scm \
language/ghil.scm language/glil.scm language/assembly.scm \

3
module/ice-9/psyntax-pp.scm
View file

@ -54,7 +54,8 @@
(let ((id293 (if (syntax-object?99 id292)
(syntax-object-expression100 id292)
id292)))
(gensym (symbol->string id293)))))
(gensym
(string-append (symbol->string id293) " ")))))
(strip161
(lambda (x294 w295)
(if (memq (quote top) (wrap-marks118 w295))

6
module/ice-9/psyntax.scm
View file

@ -1,6 +1,6 @@
;;;; -*-scheme-*-
;;;;
;;;; Copyright (C) 2001, 2003, 2006 Free Software Foundation, Inc.
;;;; Copyright (C) 2001, 2003, 2006, 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
@ -529,10 +529,10 @@
`(letrec ,(map list vars val-exps) ,body-exp)
src))))))
;; FIXME: wingo: use make-lexical ?
;; FIXME: use a faster gensym
(define-syntax build-lexical-var
(syntax-rules ()
((_ src id) (gensym (symbol->string id)))))
((_ src id) (gensym (string-append (symbol->string id) " ")))))
(define-structure (syntax-object expression wrap module))

36
module/language/assembly.scm
View file

@ -24,12 +24,12 @@
#:use-module (system vm instruction)
#:use-module ((srfi srfi-1) #:select (fold))
#:export (byte-length
addr+ align-program align-code
addr+ align-program align-code align-block
assembly-pack assembly-unpack
object->assembly assembly->object))
;; nargs, nrest, nlocs, nexts, len, metalen
(define *program-header-len* (+ 1 1 1 1 4 4))
;; nargs, nrest, nlocs, len, metalen, padding
(define *program-header-len* (+ 1 1 2 4 4 4))
;; lengths are encoded in 3 bytes
(define *len-len* 3)
@ -54,7 +54,7 @@
(+ 1 *len-len* (bytevector-length bv)))
((define ,str)
(+ 1 *len-len* (string-length str)))
((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst)))
@ -63,17 +63,24 @@
(define *program-alignment* 8)
(define *block-alignment* 8)
(define (addr+ addr code)
(fold (lambda (x len) (+ (byte-length x) len))
addr
code))
(define (code-alignment addr alignment header-len)
(make-list (modulo (- alignment
(modulo (+ addr header-len) alignment))
alignment)
'(nop)))
(define (align-block addr)
(code-alignment addr *block-alignment* 0))
(define (align-code code addr alignment header-len)
`(,@(make-list (modulo (- alignment
(modulo (+ addr header-len) alignment))
alignment)
'(nop))
`(,@(code-alignment addr alignment header-len)
,code))
(define (align-program prog addr)
@ -110,7 +117,7 @@
((null? x) `(make-eol))
((and (integer? x) (exact? x))
(cond ((and (<= -128 x) (< x 128))
`(make-int8 ,(modulo x 256)))
(assembly-pack `(make-int8 ,(modulo x 256))))
((and (<= -32768 x) (< x 32768))
(let ((n (if (< x 0) (+ x 65536) x)))
`(make-int16 ,(quotient n 256) ,(modulo n 256))))
@ -125,7 +132,11 @@
(bytevector-s64-set! bv 0 x (endianness big))
bv))))
(else #f)))
((char? x) `(make-char8 ,(char->integer x)))
((char? x)
(cond ((<= (char->integer x) #xff)
`(make-char8 ,(char->integer x)))
(else
`(make-char32 ,(char->integer x)))))
(else #f)))
(define (assembly->object code)
@ -151,6 +162,11 @@
(endianness big)))
((make-char8 ,n)
(integer->char n))
((make-char32 ,n1 ,n2 ,n3 ,n4)
(integer->char (+ (* n1 #x1000000)
(* n2 #x10000)
(* n3 #x100)
n4)))
((load-string ,s) s)
((load-symbol ,s) (string->symbol s))
((load-keyword ,s) (symbol->keyword (string->symbol s)))

19
module/language/assembly/compile-bytecode.scm
View file

@ -77,10 +77,19 @@
;; Ew!
(for-each write-byte (bytevector->u8-list bv)))
(define (write-break label)
(write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2))))
(let ((offset (- (assq-ref labels label)
(logand (+ (get-addr) 2) (lognot #x7)))))
(cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset))
((>= offset (ash 1 18)) (error "jump too far forward" offset))
((< offset (- (ash 1 18))) (error "jump too far backwards" offset))
(else (write-uint16-be (ash offset -3))))))
(let ((inst (car asm))
(args (cdr asm))
(write-uint16 (case byte-order
((1234) write-uint16-le)
((4321) write-uint16-be)
(else (error "unknown endianness" byte-order))))
(write-uint32 (case byte-order
((1234) write-uint32-le)
((4321) write-uint32-be)
@ -89,14 +98,13 @@
(len (instruction-length inst)))
(write-byte opcode)
(pmatch asm
((load-program ,nargs ,nrest ,nlocs ,nexts
,labels ,length ,meta . ,code)
((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
(write-byte nargs)
(write-byte nrest)
(write-byte nlocs)
(write-byte nexts)
(write-uint16 nlocs)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
(write-uint32 0) ; padding
(letrec ((i 0)
(write (lambda (x) (set! i (1+ i)) (write-byte x)))
(get-addr (lambda () i)))
@ -114,6 +122,7 @@
;; meets the alignment requirements of `scm_objcode'. See
;; `scm_c_make_objcode_slice ()'.
(write-bytecode meta write get-addr '()))))
((make-char32 ,x) (write-uint32-be x))
((load-unsigned-integer ,str) (write-loader str))
((load-integer ,str) (write-loader str))
((load-number ,str) (write-loader str))

12
module/language/assembly/decompile-bytecode.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM code converters
;; 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
@ -48,17 +48,21 @@
x
(- x (ash 1 16)))))
;; FIXME: this is a little-endian disassembly!!!
(define (decode-load-program pop)
(let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (nexts (pop))
(let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop))
(nlocs (+ nlocs0 (ash nlocs1 8)))
(a (pop)) (b (pop)) (c (pop)) (d (pop))
(e (pop)) (f (pop)) (g (pop)) (h (pop))
(len (+ a (ash b 8) (ash c 16) (ash d 24)))
(metalen (+ e (ash f 8) (ash g 16) (ash h 24)))
(totlen (+ len metalen))
(pad0 (pop)) (pad1 (pop)) (pad2 (pop)) (pad3 (pop))
(labels '())
(i 0))
(define (ensure-label rel1 rel2)
(let ((where (+ i (bytes->s16 rel1 rel2))))
(let ((where (+ (logand i (lognot #x7))
(* (bytes->s16 rel1 rel2) 8))))
(or (assv-ref labels where)
(begin
(let ((l (gensym ":L")))
@ -74,7 +78,7 @@
(cond ((> i len)
(error "error decoding program -- read too many bytes" out))
((= i len)
`(load-program ,nargs ,nrest ,nlocs ,nexts
`(load-program ,nargs ,nrest ,nlocs
,(map (lambda (x) (cons (cdr x) (car x)))
(reverse labels))
,len

40
module/language/assembly/disassemble.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM code converters
;; 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
@ -35,12 +35,11 @@
(define (disassemble-load-program asm env)
(pmatch asm
((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
(let ((objs (and env (assq-ref env 'objects)))
(free-vars (and env (assq-ref env 'free-vars)))
(meta (and env (assq-ref env 'meta)))
(exts (and env (assq-ref env 'exts)))
(blocs (and env (assq-ref env 'blocs)))
(bexts (and env (assq-ref env 'bexts)))
(srcs (and env (assq-ref env 'sources))))
(let lp ((pos 0) (code code) (programs '()))
(cond
@ -63,13 +62,13 @@
(acons sym asm programs))))
(else
(print-info pos asm
(code-annotation end asm objs nargs blocs bexts
(code-annotation end asm objs nargs blocs
labels)
(and=> (and srcs (assq end srcs)) source->string))
(lp (+ pos (byte-length asm)) (cdr code) programs)))))))
(if (pair? exts)
(disassemble-externals exts))
(if (pair? free-vars)
(disassemble-free-vars free-vars))
(if meta
(disassemble-meta meta))
@ -92,13 +91,12 @@
((= n len) (newline))
(print-info n (vector-ref objs n) #f #f))))
(define (disassemble-externals exts)
(display "Externals:\n\n")
(let ((len (length exts)))
(do ((n 0 (1+ n))
(l exts (cdr l)))
((null? l) (newline))
(print-info n (car l) #f #f))))
(define (disassemble-free-vars free-vars)
(display "Free variables:\n\n")
(let ((i 0))
(cond ((< i (vector-length free-vars))
(print-info i (vector-ref free-vars i) #f #f)
(lp (1+ i))))))
(define-macro (unless test . body)
`(if (not ,test) (begin ,@body)))
@ -122,7 +120,7 @@
(define (make-int16 byte1 byte2)
(+ (* byte1 256) byte2))
(define (code-annotation end-addr code objs nargs blocs bexts labels)
(define (code-annotation end-addr code objs nargs blocs labels)
(let* ((code (assembly-unpack code))
(inst (car code))
(args (cdr code)))
@ -133,7 +131,7 @@
(list "-> ~A" (assq-ref labels (car args))))
((object-ref)
(and objs (list "~s" (vector-ref objs (car args)))))
((local-ref local-set)
((local-ref local-boxed-ref local-set local-boxed-set)
(and blocs
(let lp ((bindings (list-ref blocs (car args))))
(and (pair? bindings)
@ -143,13 +141,9 @@
(list "`~a'~@[ (arg)~]"
(binding:name b) (< (binding:index b) nargs))
(lp (cdr bindings))))))))
((external-ref external-set)
(and bexts
(if (< (car args) (length bexts))
(let ((b (list-ref bexts (car args))))
(list "`~a'~@[ (arg)~]"
(binding:name b) (< (binding:index b) nargs)))
(list "(closure variable)"))))
((free-ref free-boxed-ref free-boxed-set)
;; FIXME: we can do better than this
(list "(closure variable)"))
((toplevel-ref toplevel-set)
(and objs
(let ((v (vector-ref objs (car args))))

54
module/language/glil.scm
View file

@ -1,6 +1,6 @@
;;; Guile Low 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
@ -24,9 +24,9 @@
#:use-module ((srfi srfi-1) #:select (fold))
#:export
(<glil-program> make-glil-program glil-program?
glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts
glil-program-meta glil-program-body glil-program-closure-level
glil-program-nargs glil-program-nrest glil-program-nlocs
glil-program-meta glil-program-body
<glil-bind> make-glil-bind glil-bind?
glil-bind-vars
@ -43,11 +43,8 @@
<glil-const> make-glil-const glil-const?
glil-const-obj
<glil-local> make-glil-local glil-local?
glil-local-op glil-local-index
<glil-external> make-glil-external glil-external?
glil-external-op glil-external-depth glil-external-index
<glil-lexical> make-glil-lexical glil-lexical?
glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
<glil-toplevel> make-glil-toplevel glil-toplevel?
glil-toplevel-op glil-toplevel-name
@ -74,7 +71,7 @@
(define-type (<glil> #:printer print-glil)
;; Meta operations
(<glil-program> nargs nrest nlocs nexts meta body (closure-level #f))
(<glil-program> nargs nrest nlocs meta body)
(<glil-bind> vars)
(<glil-mv-bind> vars rest)
(<glil-unbind>)
@ -83,8 +80,7 @@
(<glil-void>)
(<glil-const> obj)
;; Variables
(<glil-local> op index)
(<glil-external> op depth index)
(<glil-lexical> local? boxed? op index)
(<glil-toplevel> op name)
(<glil-module> op mod name public?)
;; Controls
@ -93,35 +89,19 @@
(<glil-call> inst nargs)
(<glil-mv-call> nargs ra))
(define (compute-closure-level body)
(fold (lambda (x ret)
(record-case x
((<glil-program> closure-level) (max ret closure-level))
((<glil-external> depth) (max ret depth))
(else ret)))
0 body))
(define %make-glil-program make-glil-program)
(define (make-glil-program . args)
(let ((prog (apply %make-glil-program args)))
(if (not (glil-program-closure-level prog))
(set! (glil-program-closure-level prog)
(compute-closure-level (glil-program-body prog))))
prog))
(define (parse-glil x)
(pmatch x
((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
(make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
((program ,nargs ,nrest ,nlocs ,meta . ,body)
(make-glil-program nargs nrest nlocs meta (map parse-glil body)))
((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
((unbind) (make-glil-unbind))
((source ,props) (make-glil-source props))
((void) (make-glil-void))
((const ,obj) (make-glil-const obj))
((local ,op ,index) (make-glil-local op index))
((external ,op ,depth ,index) (make-glil-external op depth index))
((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
((toplevel ,op ,name) (make-glil-toplevel op name))
((module public ,op ,mod ,name) (make-glil-module op mod name #t))
((module private ,op ,mod ,name) (make-glil-module op mod name #f))
@ -134,8 +114,8 @@
(define (unparse-glil glil)
(record-case glil
;; meta
((<glil-program> nargs nrest nlocs nexts meta body)
`(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
((<glil-program> nargs nrest nlocs meta body)
`(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
((<glil-unbind>) `(unbind))
@ -144,10 +124,8 @@
((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj))
;; variables
((<glil-local> op index)
`(local ,op ,index))
((<glil-external> op depth index)
`(external ,op ,depth ,index))
((<glil-lexical> local? boxed? op index)
`(lexical ,local? ,boxed? ,op ,index))
((<glil-toplevel> op name)
`(toplevel ,op ,name))
((<glil-module> op mod name public?)

197
module/language/glil/compile-assembly.scm
View file

@ -72,14 +72,14 @@
(if (and (null? bindings) (null? sources) (null? tail))
#f
(compile-assembly
(make-glil-program 0 0 0 0 '()
(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 ext? index)
(list name ext? index))
(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))
@ -89,8 +89,8 @@
(map
(lambda (v)
(pmatch v
((,name local ,i) (make-open-binding name #f i))
((,name external ,i) (make-open-binding name #t i))
((,name ,boxed? ,i)
(make-open-binding name boxed? i))
(else (error "unknown binding type" v))))
vars)
(car bindings))
@ -128,74 +128,77 @@
(define (compile-assembly glil)
(receive (code . _)
(glil->assembly glil '() '(()) '() '() #f -1)
(glil->assembly glil #t '(()) '() '() #f -1)
(car code)))
(define (make-object-table objects)
(and (not (null? objects))
(list->vector (cons #f objects))))
(define (glil->assembly glil nexts-stack bindings
(define (glil->assembly glil toplevel? bindings
source-alist label-alist object-alist addr)
(define (emit-code x)
(values (map assembly-pack x) bindings source-alist label-alist object-alist))
(values x bindings source-alist label-alist object-alist))
(define (emit-code/object x object-alist)
(values (map assembly-pack x) bindings source-alist label-alist object-alist))
(values x bindings source-alist label-alist object-alist))
(record-case glil
((<glil-program> nargs nrest nlocs nexts meta body closure-level)
(let ((toplevel? (null? nexts-stack)))
(define (process-body)
(let ((nexts-stack (cons nexts nexts-stack)))
(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
(label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
(cond
((null? body)
(values (reverse code)
(close-all-bindings bindings addr)
(limn-sources (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) nexts-stack bindings
source-alist label-alist object-alist addr)
(lp (cdr body) (append (reverse subcode) code)
bindings source-alist label-alist object-alist
(addr+ addr subcode))))))))
((<glil-program> nargs nrest nlocs meta body)
(define (process-body)
(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
(label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
(cond
((null? body)
(values (reverse code)
(close-all-bindings bindings addr)
(limn-sources (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) #f bindings
source-alist label-alist object-alist addr)
(lp (cdr body) (append (reverse subcode) code)
bindings source-alist label-alist object-alist
(addr+ addr subcode)))))))
(receive (code bindings sources labels objects len)
(process-body)
(let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
,len
,(make-meta bindings sources meta)
. ,code)))
(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 (align-program prog addr)))
(else
(let ((table (dump-object (make-object-table objects) addr))
(closure (if (> closure-level 0) '((make-closure)) '())))
(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)))
,@closure)
object-alist)))
(else
;; otherwise emit a load directly
(emit-code `(,@table ,@(align-program prog (addr+ addr table))
,@closure)))))))))))
(receive (code bindings sources labels objects len)
(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 (align-program prog addr)))
(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 '()
@ -244,19 +247,45 @@
,(modulo i 256))))
object-alist)))))
((<glil-local> op index)
(emit-code (if (eq? op 'ref)
`((local-ref ,index))
`((local-set ,index)))))
((<glil-external> 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))))))))
((<glil-lexical> local? boxed? op index)
(emit-code
(if local?
(if (< index 256)
`((,(case op
((ref) (if boxed? 'local-boxed-ref 'local-ref))
((set) (if boxed? 'local-boxed-set 'local-set))
((box) 'box)
((empty-box) 'empty-box)
(else (error "what" op)))
,index))
(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)))
(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)
@ -311,11 +340,12 @@
(error "unknown module var kind" op key)))))
((<glil-label> label)
(values '()
bindings
source-alist
(acons label addr label-alist)
object-alist))
(let ((code (align-block addr)))
(values code
bindings
source-alist
(acons label (addr+ addr code) label-alist)
object-alist)))
((<glil-branch> inst label)
(emit-code `((,inst ,label))))
@ -348,9 +378,10 @@
((object->assembly x) => list)
((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
((subprogram? x)
`(,@(subprogram-table x)
,@(align-program (subprogram-prog x)
(addr+ addr (subprogram-table x)))))
(let ((table-code (dump-object (subprogram-table x) addr)))
`(,@table-code
,@(align-program (subprogram-prog x)
(addr+ addr table-code)))))
((number? x)
`((load-number ,(number->string x))))
((string? x)

20
module/language/glil/decompile-assembly.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM code converters
;; 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
@ -31,8 +31,8 @@
(define (decompile-toplevel x)
(pmatch x
((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,body)
(decompile-load-program nargs nrest nlocs nexts
((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
(decompile-load-program nargs nrest nlocs
(decompile-meta meta)
body labels #f))
(else
@ -56,7 +56,7 @@
((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
(else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
(define (decompile-load-program nargs nrest nlocs nexts meta body labels
(define (decompile-load-program nargs nrest nlocs meta body labels
objects)
(let ((glil-labels (sort (map (lambda (x)
(cons (cdr x) (make-glil-label (car x))))
@ -100,19 +100,11 @@
(cond
((null? in)
(or (null? stack) (error "leftover stack insts" stack body))
(make-glil-program nargs nrest nlocs nexts props (reverse out) #f))
(make-glil-program nargs nrest nlocs props (reverse out) #f))
((pop-bindings! pos)
=> (lambda (bindings)
(lp in stack
(cons (make-glil-bind
(map (lambda (x)
(let ((name (binding:name x))
(i (binding:index x)))
(cond
((binding:extp x) `(,name external ,i))
((< i nargs) `(,name argument ,i))
(else `(,name local ,(- i nargs))))))
bindings))
(cons (make-glil-bind bindings)
out)
pos)))
((pop-unbindings! pos)

17
module/language/objcode/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
@ -31,7 +31,7 @@
(if env (car env) (current-module)))
(define (objcode-env-externals env)
(if env (cdr env) '()))
(and env (vector? (cdr env)) (cdr env)))
(define (objcode->value x e opts)
(let ((thunk (make-program x #f (objcode-env-externals e))))
@ -66,23 +66,16 @@
((program? x)
(let ((objs (program-objects x))
(meta (program-meta x))
(exts (program-external x))
(free-vars (program-free-variables x))
(binds (program-bindings x))
(srcs (program-sources x))
(nargs (arity:nargs (program-arity x))))
(let ((blocs (and binds
(collapse-locals
(append (list-head binds nargs)
(filter (lambda (x) (not (binding:extp x)))
(list-tail binds nargs))))))
(bexts (and binds
(filter binding:extp binds))))
(let ((blocs (and binds (collapse-locals binds))))
(values (program-objcode x)
`((objects . ,objs)
(meta . ,(and meta (meta)))
(exts . ,exts)
(free-vars . ,free-vars)
(blocs . ,blocs)
(bexts . ,bexts)
(sources . ,srcs))))))
((objcode? x)
(values x #f))

49
module/language/tree-il.scm
View file

@ -17,6 +17,7 @@
(define-module (language tree-il)
#:use-module (srfi srfi-1)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:export (tree-il-src
@ -38,11 +39,12 @@
<let> let? make-let let-src let-names let-vars let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
<let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
parse-tree-il
unparse-tree-il
tree-il->scheme
tree-il-fold
post-order!
pre-order!))
@ -258,6 +260,51 @@
`(call-with-values (lambda () ,(tree-il->scheme exp))
(lambda ,vars ,(tree-il->scheme body))))))
(define (tree-il-fold leaf down up seed tree)
"Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is
invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
and SEED is the current result, intially seeded with SEED.
This is an implementation of `foldts' as described by Andy Wingo in
``Applications of fold to XML transformation''."
(let loop ((tree tree)
(result seed))
(if (or (null? tree) (pair? tree))
(fold loop result tree)
(record-case tree
((<lexical-set> exp)
(up tree (loop exp (down tree result))))
((<module-set> exp)
(up tree (loop exp (down tree result))))
((<toplevel-set> exp)
(up tree (loop exp (down tree result))))
((<toplevel-define> exp)
(up tree (loop exp (down tree result))))
((<conditional> test then else)
(up tree (loop else
(loop then
(loop test (down tree result))))))
((<application> proc args)
(up tree (loop (cons proc args) (down tree result))))
((<sequence> exps)
(up tree (loop exps (down tree result))))
((<lambda> body)
(up tree (loop body (down tree result))))
((<let> vals body)
(up tree (loop body
(loop vals
(down tree result)))))
((<letrec> vals body)
(up tree (loop body
(loop vals
(down tree result)))))
((<let-values> body)
(up tree (loop body (down tree result))))
(else
(leaf tree result))))))
(define (post-order! f x)
(let lp ((x x))
(record-case x

521
module/language/tree-il/analyze.scm
View file

@ -19,14 +19,40 @@
;;; Code:
(define-module (language tree-il analyze)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (system base syntax)
#:use-module (system base message)
#:use-module (language tree-il)
#:export (analyze-lexicals))
#:export (analyze-lexicals
report-unused-variables))
;; allocation: the process of assigning a type and index to each var
;; a var is external if it is heaps; assigning index is easy
;; args are assigned in order
;; locals are indexed as their linear position in the binding path
;; Allocation is the process of assigning storage locations for lexical
;; variables. A lexical variable has a distinct "address", or storage
;; location, for each procedure in which it is referenced.
;;
;; A variable is "local", i.e., allocated on the stack, if it is
;; referenced from within the procedure that defined it. Otherwise it is
;; a "closure" variable. For example:
;;
;; (lambda (a) a) ; a will be local
;; `a' is local to the procedure.
;;
;; (lambda (a) (lambda () a))
;; `a' is local to the outer procedure, but a closure variable with
;; respect to the inner procedure.
;;
;; If a variable is ever assigned, it needs to be heap-allocated
;; ("boxed"). This is so that closures and continuations capture the
;; variable's identity, not just one of the values it may have over the
;; course of program execution. If the variable is never assigned, there
;; is no distinction between value and identity, so closing over its
;; identity (whether through closures or continuations) can make a copy
;; of its value instead.
;;
;; Local variables are stored on the stack within a procedure's call
;; frame. Their index into the stack is determined from their linear
;; postion within a procedure's binding path:
;; (let (0 1)
;; (let (2 3) ...)
;; (let (2) ...))
@ -48,49 +74,67 @@
;; case. A proper solution would be some sort of liveness analysis, and
;; not our linear allocation algorithm.
;;
;; allocation:
;; sym -> (local . index) | (heap level . index)
;; lambda -> (nlocs . nexts)
;; Closure variables are captured when a closure is created, and stored
;; in a vector. Each closure variable has a unique index into that
;; vector.
;;
;;
;; The return value of `analyze-lexicals' is a hash table, the
;; "allocation".
;;
;; The allocation maps gensyms -- recall that each lexically bound
;; variable has a unique gensym -- to storage locations ("addresses").
;; Since one gensym may have many storage locations, if it is referenced
;; in many procedures, it is a two-level map.
;;
;; The allocation also stored information on how many local variables
;; need to be allocated for each procedure, and information on what free
;; variables to capture from its lexical parent procedure.
;;
;; That is:
;;
;; sym -> {lambda -> address}
;; lambda -> (nlocs . free-locs)
;;
;; address := (local? boxed? . index)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.
(define (make-hashq k v)
(let ((res (make-hash-table)))
(hashq-set! res k v)
res))
(define (analyze-lexicals x)
;; parents: lambda -> parent
;; useful when we see a closed-over var, so we can calculate its
;; coordinates (depth and index).
;; bindings: lambda -> (sym ...)
;; useful for two reasons: one, so we know how much space to allocate
;; when we go into a lambda; and two, so that we know when to stop,
;; when looking for closed-over vars.
;; heaps: sym -> lambda
;; allows us to heapify vars in an O(1) fashion
;; bound-vars: lambda -> (sym ...)
;; all identifiers bound within a lambda
;; free-vars: lambda -> (sym ...)
;; all identifiers referenced in a lambda, but not bound
;; NB, this includes identifiers referenced by contained lambdas
;; assigned: sym -> #t
;; variables that are assigned
;; refcounts: sym -> count
;; allows us to detect the or-expansion an O(1) time
(define (find-heap sym parent)
;; fixme: check displaced lexicals here?
(if (memq sym (hashq-ref bindings parent))
parent
(find-heap sym (hashq-ref parents parent))))
(define (analyze! x parent level)
(define (step y) (analyze! y parent level))
(define (recur x parent) (analyze! x parent (1+ level)))
;; allows us to detect the or-expansion in O(1) time
;; returns variables referenced in expr
(define (analyze! x proc)
(define (step y) (analyze! y proc))
(define (recur x new-proc) (analyze! x new-proc))
(record-case x
((<application> proc args)
(step proc) (for-each step args))
(apply lset-union eq? (step proc) (map step args)))
((<conditional> test then else)
(step test) (step then) (step else))
(lset-union eq? (step test) (step then) (step else)))
((<lexical-ref> name gensym)
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
(if (and (not (memq gensym (hashq-ref bindings parent)))
(not (hashq-ref heaps gensym)))
(hashq-set! heaps gensym (find-heap gensym parent))))
(list gensym))
((<lexical-set> name gensym exp)
(step exp)
(if (not (hashq-ref heaps gensym))
(hashq-set! heaps gensym (find-heap gensym parent))))
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
(hashq-set! assigned gensym #t)
(lset-adjoin eq? (step exp) gensym))
((<module-set> mod name public? exp)
(step exp))
@ -102,157 +146,292 @@
(step exp))
((<sequence> exps)
(for-each step exps))
(apply lset-union eq? (map step exps)))
((<lambda> vars meta body)
(hashq-set! parents x parent)
(hashq-set! bindings x
(let rev* ((vars vars) (out '()))
(cond ((null? vars) out)
((pair? vars) (rev* (cdr vars)
(cons (car vars) out)))
(else (cons vars out)))))
(recur body x)
(hashq-set! bindings x (reverse! (hashq-ref bindings x))))
(let ((locally-bound (let rev* ((vars vars) (out '()))
(cond ((null? vars) out)
((pair? vars) (rev* (cdr vars)
(cons (car vars) out)))
(else (cons vars out))))))
(hashq-set! bound-vars x locally-bound)
(let* ((referenced (recur body x))
(free (lset-difference eq? referenced locally-bound))
(all-bound (reverse! (hashq-ref bound-vars x))))
(hashq-set! bound-vars x all-bound)
(hashq-set! free-vars x free)
free)))
((<let> vars vals body)
(for-each step vals)
(hashq-set! bindings parent
(append (reverse vars) (hashq-ref bindings parent)))
(step body))
(hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc)))
(lset-difference eq?
(apply lset-union eq? (step body) (map step vals))
vars))
((<letrec> vars vals body)
(hashq-set! bindings parent
(append (reverse vars) (hashq-ref bindings parent)))
(for-each step vals)
(step body))
(hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc)))
(for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
(lset-difference eq?
(apply lset-union eq? (step body) (map step vals))
vars))
((<let-values> vars exp body)
(hashq-set! bindings parent
(let lp ((out (hashq-ref bindings parent)) (in vars))
(hashq-set! bound-vars proc
(let lp ((out (hashq-ref bound-vars proc)) (in vars))
(if (pair? in)
(lp (cons (car in) out) (cdr in))
(if (null? in) out (cons in out)))))
(step exp)
(step body))
(lset-difference eq?
(lset-union eq? (step exp) (step body))
vars))
(else '())))
(define (allocate! x proc n)
(define (recur y) (allocate! y proc n))
(record-case x
((<application> proc args)
(apply max (recur proc) (map recur args)))
(else #f)))
((<conditional> test then else)
(max (recur test) (recur then) (recur else)))
(define (allocate-heap! binder)
(hashq-set! heap-indexes binder
(1+ (hashq-ref heap-indexes binder -1))))
((<lexical-set> name gensym exp)
(recur exp))
((<module-set> mod name public? exp)
(recur exp))
((<toplevel-set> name exp)
(recur exp))
((<toplevel-define> name exp)
(recur exp))
((<sequence> exps)
(apply max (map recur exps)))
((<lambda> vars meta body)
;; allocate closure vars in order
(let lp ((c (hashq-ref free-vars x)) (n 0))
(if (pair? c)
(begin
(hashq-set! (hashq-ref allocation (car c))
x
`(#f ,(hashq-ref assigned (car c)) . ,n))
(lp (cdr c) (1+ n)))))
(let ((nlocs
(let lp ((vars vars) (n 0))
(if (not (null? vars))
;; allocate args
(let ((v (if (pair? vars) (car vars) vars)))
(hashq-set! allocation v
(make-hashq
x `(#t ,(hashq-ref assigned v) . ,n)))
(lp (if (pair? vars) (cdr vars) '()) (1+ n)))
;; allocate body, return number of additional locals
(- (allocate! body x n) n))))
(free-addresses
(map (lambda (v)
(hashq-ref (hashq-ref allocation v) proc))
(hashq-ref free-vars x))))
;; set procedure allocations
(hashq-set! allocation x (cons nlocs free-addresses)))
n)
(define (allocate! x level n)
(define (recur y) (allocate! y level n))
(record-case x
((<application> proc args)
(apply max (recur proc) (map recur args)))
((<conditional> test then else)
(max (recur test) (recur then) (recur else)))
((<lexical-set> name gensym exp)
(recur exp))
((<module-set> mod name public? exp)
(recur exp))
((<toplevel-set> name exp)
(recur exp))
((<toplevel-define> name exp)
(recur exp))
((<sequence> exps)
(apply max (map recur exps)))
((<lambda> vars meta body)
(let lp ((vars vars) (n 0))
(if (null? vars)
(hashq-set! allocation x
(let ((nlocs (- (allocate! body (1+ level) n) n)))
(cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
(let ((v (if (pair? vars) (car vars) vars)))
(let ((binder (hashq-ref heaps v)))
(hashq-set!
allocation v
(if binder
(cons* 'heap (1+ level) (allocate-heap! binder))
(cons 'stack n))))
(lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
n)
((<let> vars vals body)
(let ((nmax (apply max (map recur vals))))
(cond
;; the `or' hack
((and (conditional? body)
(= (length vars) 1)
(let ((v (car vars)))
(and (not (hashq-ref heaps v))
(= (hashq-ref refcounts v 0) 2)
(lexical-ref? (conditional-test body))
(eq? (lexical-ref-gensym (conditional-test body)) v)
(lexical-ref? (conditional-then body))
(eq? (lexical-ref-gensym (conditional-then body)) v))))
(hashq-set! allocation (car vars) (cons 'stack n))
;; the 1+ for this var
(max nmax (1+ n) (allocate! (conditional-else body) level n)))
(else
(let lp ((vars vars) (n n))
(if (null? vars)
(max nmax (allocate! body level n))
(let ((v (car vars)))
(let ((binder (hashq-ref heaps v)))
(hashq-set!
allocation v
(if binder
(cons* 'heap level (allocate-heap! binder))
(cons 'stack n)))
(lp (cdr vars) (if binder n (1+ n)))))))))))
((<letrec> vars vals body)
(let lp ((vars vars) (n n))
(if (null? vars)
(let ((nmax (apply max
(map (lambda (x)
(allocate! x level n))
vals))))
(max nmax (allocate! body level n)))
(let ((v (car vars)))
(let ((binder (hashq-ref heaps v)))
(hashq-set!
allocation v
(if binder
(cons* 'heap level (allocate-heap! binder))
(cons 'stack n)))
(lp (cdr vars) (if binder n (1+ n))))))))
((<let-values> vars exp body)
(let ((nmax (recur exp)))
((<let> vars vals body)
(let ((nmax (apply max (map recur vals))))
(cond
;; the `or' hack
((and (conditional? body)
(= (length vars) 1)
(let ((v (car vars)))
(and (not (hashq-ref assigned v))
(= (hashq-ref refcounts v 0) 2)
(lexical-ref? (conditional-test body))
(eq? (lexical-ref-gensym (conditional-test body)) v)
(lexical-ref? (conditional-then body))
(eq? (lexical-ref-gensym (conditional-then body)) v))))
(hashq-set! allocation (car vars)
(make-hashq proc `(#t #f . ,n)))
;; the 1+ for this var
(max nmax (1+ n) (allocate! (conditional-else body) proc n)))
(else
(let lp ((vars vars) (n n))
(if (null? vars)
(max nmax (allocate! body level n))
(let ((v (if (pair? vars) (car vars) vars)))
(let ((binder (hashq-ref heaps v)))
(hashq-set!
allocation v
(if binder
(cons* 'heap level (allocate-heap! binder))
(cons 'stack n)))
(lp (if (pair? vars) (cdr vars) '())
(if binder n (1+ n)))))))))
(else n)))
(max nmax (allocate! body proc n))
(let ((v (car vars)))
(hashq-set!
allocation v
(make-hashq proc
`(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ n)))))))))
((<letrec> vars vals body)
(let lp ((vars vars) (n n))
(if (null? vars)
(let ((nmax (apply max
(map (lambda (x)
(allocate! x proc n))
vals))))
(max nmax (allocate! body proc n)))
(let ((v (car vars)))
(hashq-set!
allocation v
(make-hashq proc
`(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ n))))))
(define parents (make-hash-table))
(define bindings (make-hash-table))
(define heaps (make-hash-table))
((<let-values> vars exp body)
(let ((nmax (recur exp)))
(let lp ((vars vars) (n n))
(if (null? vars)
(max nmax (allocate! body proc n))
(let ((v (if (pair? vars) (car vars) vars)))
(let ((v (car vars)))
(hashq-set!
allocation v
(make-hashq proc
`(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ n))))))))
(else n)))
(define bound-vars (make-hash-table))
(define free-vars (make-hash-table))
(define assigned (make-hash-table))
(define refcounts (make-hash-table))
(define allocation (make-hash-table))
(define heap-indexes (make-hash-table))
(analyze! x #f -1)
(allocate! x -1 0)
(analyze! x #f)
(allocate! x #f 0)
allocation)
;;;
;;; Unused variable analysis.
;;;
;; <binding-info> records are used during tree traversals in
;; `report-unused-variables'. They contain a list of the local vars
;; currently in scope, a list of locals vars that have been referenced, and a
;; "location stack" (the stack of `tree-il-src' values for each parent tree).
(define-record-type <binding-info>
(make-binding-info vars refs locs)
binding-info?
(vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...)
(refs binding-info-refs) ;; (GENSYM ...)
(locs binding-info-locs)) ;; (LOCATION ...)
(define (report-unused-variables tree)
"Report about unused variables in TREE. Return TREE."
(define (dotless-list lst)
;; If LST is a dotted list, return a proper list equal to LST except that
;; the very last element is a pair; otherwise return LST.
(let loop ((lst lst)
(result '()))
(cond ((null? lst)
(reverse result))
((pair? lst)
(loop (cdr lst) (cons (car lst) result)))
(else
(loop '() (cons lst result))))))
(tree-il-fold (lambda (x info)
;; X is a leaf: extend INFO's refs accordingly.
(let ((refs (binding-info-refs info))
(vars (binding-info-vars info))
(locs (binding-info-locs info)))
(record-case x
((<lexical-ref> gensym)
(make-binding-info vars (cons gensym refs) locs))
(else info))))
(lambda (x info)
;; Going down into X: extend INFO's variable list
;; accordingly.
(let ((refs (binding-info-refs info))
(vars (binding-info-vars info))
(locs (binding-info-locs info))
(src (tree-il-src x)))
(define (extend inner-vars inner-names)
(append (map (lambda (var name)
(list var name src))
inner-vars
inner-names)
vars))
(record-case x
((<lexical-set> gensym)
(make-binding-info vars (cons gensym refs)
(cons src locs)))
((<lambda> vars names)
(let ((vars (dotless-list vars))
(names (dotless-list names)))
(make-binding-info (extend vars names) refs
(cons src locs))))
((<let> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
((<letrec> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
((<let-values> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
(else info))))
(lambda (x info)
;; Leaving X's scope: shrink INFO's variable list
;; accordingly and reported unused nested variables.
(let ((refs (binding-info-refs info))
(vars (binding-info-vars info))
(locs (binding-info-locs info)))
(define (shrink inner-vars refs)
(for-each (lambda (var)
(let ((gensym (car var)))
;; Don't report lambda parameters as
;; unused.
(if (and (not (memq gensym refs))
(not (and (lambda? x)
(memq gensym
inner-vars))))
(let ((name (cadr var))
;; We can get approximate
;; source location by going up
;; the LOCS location stack.
(loc (or (caddr var)
(find pair? locs))))
(warning 'unused-variable loc name)))))
(filter (lambda (var)
(memq (car var) inner-vars))
vars))
(fold alist-delete vars inner-vars))
;; For simplicity, we leave REFS untouched, i.e., with
;; names of variables that are now going out of scope.
;; It doesn't hurt as these are unique names, it just
;; makes REFS unnecessarily fat.
(record-case x
((<lambda> vars)
(let ((vars (dotless-list vars)))
(make-binding-info (shrink vars refs) refs
(cdr locs))))
((<let> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
((<letrec> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
((<let-values> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
(else info))))
(make-binding-info '() '() '())
tree)
tree)

182
module/language/tree-il/compile-glil.scm
View file

@ -20,6 +20,8 @@
(define-module (language tree-il compile-glil)
#:use-module (system base syntax)
#:use-module (system base pmatch)
#:use-module (system base message)
#:use-module (ice-9 receive)
#:use-module (language glil)
#:use-module (system vm instruction)
@ -34,18 +36,37 @@
;; basic degenerate-case reduction
;; allocation:
;; sym -> (local . index) | (heap level . index)
;; lambda -> (nlocs . nexts)
;; sym -> {lambda -> address}
;; lambda -> (nlocs . closure-vars)
;;
;; address := (local? boxed? . index)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.
(define *comp-module* (make-fluid))
(define %warning-passes
`((unused-variable . ,report-unused-variables)))
(define (compile-glil x e opts)
(define warnings
(or (and=> (memq #:warnings opts) cadr)
'()))
(let* ((x (make-lambda (tree-il-src x) '() '() '() x))
(x (optimize! x e opts))
(allocation (analyze-lexicals x)))
;; Go throught the warning passes.
(for-each (lambda (kind)
(let ((warn (assoc-ref %warning-passes kind)))
(and (procedure? warn)
(warn x))))
warnings)
(with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda ()
(values (flatten-lambda x -1 allocation)
(values (flatten-lambda x allocation)
(and e (cons (car e) (cddr e)))
e)))))
@ -131,20 +152,19 @@
(define (make-label) (gensym ":L"))
(define (vars->bind-list ids vars allocation)
(define (vars->bind-list ids vars allocation proc)
(map (lambda (id v)
(let ((loc (hashq-ref allocation v)))
(case (car loc)
((stack) (list id 'local (cdr loc)))
((heap) (list id 'external (cddr loc)))
(else (error "badness" id v loc)))))
(pmatch (hashq-ref (hashq-ref allocation v) proc)
((#t ,boxed? . ,n)
(list id boxed? n))
(,x (error "badness" x))))
ids
vars))
(define (emit-bindings src ids vars allocation emit-code)
(define (emit-bindings src ids vars allocation proc emit-code)
(if (pair? vars)
(emit-code src (make-glil-bind
(vars->bind-list ids vars allocation)))))
(vars->bind-list ids vars allocation proc)))))
(define (with-output-to-code proc)
(let ((out '()))
@ -155,7 +175,7 @@
(proc emit-code)
(reverse out)))
(define (flatten-lambda x level allocation)
(define (flatten-lambda x allocation)
(receive (ids vars nargs nrest)
(let lp ((ids (lambda-names x)) (vars (lambda-vars x))
(oids '()) (ovars '()) (n 0))
@ -166,31 +186,27 @@
(else (values (reverse (cons ids oids))
(reverse (cons vars ovars))
(1+ n) 1))))
(let ((nlocs (car (hashq-ref allocation x)))
(nexts (cdr (hashq-ref allocation x))))
(let ((nlocs (car (hashq-ref allocation x))))
(make-glil-program
nargs nrest nlocs nexts (lambda-meta x)
nargs nrest nlocs (lambda-meta x)
(with-output-to-code
(lambda (emit-code)
;; write bindings and source debugging info
(emit-bindings #f ids vars allocation emit-code)
(emit-bindings #f ids vars allocation x emit-code)
(if (lambda-src x)
(emit-code #f (make-glil-source (lambda-src x))))
;; copy args to the heap if necessary
(let lp ((in vars) (n 0))
(if (not (null? in))
(let ((loc (hashq-ref allocation (car in))))
(case (car loc)
((heap)
(emit-code #f (make-glil-local 'ref n))
(emit-code #f (make-glil-external 'set 0 (cddr loc)))))
(lp (cdr in) (1+ n)))))
;; box args if necessary
(for-each
(lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) x)
((#t #t . ,n)
(emit-code #f (make-glil-lexical #t #f 'ref n))
(emit-code #f (make-glil-lexical #t #t 'box n)))))
vars)
;; and here, here, dear reader: we compile.
(flatten (lambda-body x) (1+ level) allocation emit-code)))))))
(flatten (lambda-body x) allocation x emit-code)))))))
(define (flatten x level allocation emit-code)
(define (flatten x allocation proc emit-code)
(define (emit-label label)
(emit-code #f (make-glil-label label)))
(define (emit-branch src inst label)
@ -424,27 +440,21 @@
((<lexical-ref> src name gensym)
(case context
((push vals tail)
(let ((loc (hashq-ref allocation gensym)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'ref (cdr loc))))
((heap)
(emit-code src (make-glil-external
'ref (- level (cadr loc)) (cddr loc))))
(else (error "badness" x loc)))
(if (eq? context 'tail)
(emit-code #f (make-glil-call 'return 1)))))))
(pmatch (hashq-ref (hashq-ref allocation gensym) proc)
((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'ref index)))
(,loc
(error "badness" x loc)))))
(case context
((tail) (emit-code #f (make-glil-call 'return 1)))))
((<lexical-set> src name gensym exp)
(comp-push exp)
(let ((loc (hashq-ref allocation gensym)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'set (cdr loc))))
((heap)
(emit-code src (make-glil-external
'set (- level (cadr loc)) (cddr loc))))
(else (error "badness" x loc))))
(pmatch (hashq-ref (hashq-ref allocation gensym) proc)
((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'set index)))
(,loc
(error "badness" x loc)))
(case context
((push vals)
(emit-code #f (make-glil-void)))
@ -495,39 +505,52 @@
(emit-code #f (make-glil-call 'return 1)))))
((<lambda>)
(case context
((push vals)
(emit-code #f (flatten-lambda x level allocation)))
((tail)
(emit-code #f (flatten-lambda x level allocation))
(emit-code #f (make-glil-call 'return 1)))))
(let ((free-locs (cdr (hashq-ref allocation x))))
(case context
((push vals tail)
(emit-code #f (flatten-lambda x allocation))
(if (not (null? free-locs))
(begin
(for-each
(lambda (loc)
(pmatch loc
((,local? ,boxed? . ,n)
(emit-code #f (make-glil-lexical local? #f 'ref n)))
(else (error "what" x loc))))
free-locs)
(emit-code #f (make-glil-call 'vector (length free-locs)))
(emit-code #f (make-glil-call 'make-closure 2))))
(if (eq? context 'tail)
(emit-code #f (make-glil-call 'return 1)))))))
((<let> src names vars vals body)
(for-each comp-push vals)
(emit-bindings src names vars allocation emit-code)
(emit-bindings src names vars allocation proc emit-code)
(for-each (lambda (v)
(let ((loc (hashq-ref allocation v)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'set (cdr loc))))
((heap)
(emit-code src (make-glil-external 'set 0 (cddr loc))))
(else (error "badness" x loc)))))
(pmatch (hashq-ref (hashq-ref allocation v) proc)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n)))
(,loc (error "badness" x loc))))
(reverse vars))
(comp-tail body)
(emit-code #f (make-glil-unbind)))
((<letrec> src names vars vals body)
(for-each comp-push vals)
(emit-bindings src names vars allocation emit-code)
(for-each (lambda (v)
(let ((loc (hashq-ref allocation v)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'set (cdr loc))))
((heap)
(emit-code src (make-glil-external 'set 0 (cddr loc))))
(else (error "badness" x loc)))))
(pmatch (hashq-ref (hashq-ref allocation v) proc)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'empty-box n)))
(,loc (error "badness" x loc))))
vars)
(for-each comp-push vals)
(emit-bindings src names vars allocation proc emit-code)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'set n)))
(,loc (error "badness" x loc))))
(reverse vars))
(comp-tail body)
(emit-code #f (make-glil-unbind)))
@ -548,16 +571,15 @@
(emit-code #f (make-glil-const 1))
(emit-label MV)
(emit-code src (make-glil-mv-bind
(vars->bind-list names vars allocation)
(vars->bind-list names vars allocation proc)
rest?))
(for-each (lambda (v)
(let ((loc (hashq-ref allocation v)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'set (cdr loc))))
((heap)
(emit-code src (make-glil-external 'set 0 (cddr loc))))
(else (error "badness" x loc)))))
(pmatch (hashq-ref (hashq-ref allocation v) proc)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n)))
(,loc (error "badness" x loc))))
(reverse vars))
(comp-tail body)
(emit-code #f (make-glil-unbind))))))))))

34
module/scripts/compile.scm
View file

@ -30,9 +30,11 @@
(define-module (scripts compile)
#:use-module ((system base compile) #:select (compile-file))
#:use-module (system base message)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-37)
#:use-module (ice-9 format)
#:export (compile))
@ -58,6 +60,17 @@
(fail "`-o' option cannot be specified more than once")
(alist-cons 'output-file arg result))))
(option '(#\W "warn") #t #f
(lambda (opt name arg result)
(if (string=? arg "help")
(begin
(show-warning-help)
(exit 0))
(let ((warnings (assoc-ref result 'warnings)))
(alist-cons 'warnings
(cons (string->symbol arg) warnings)
(alist-delete 'warnings result))))))
(option '(#\O "optimize") #f #f
(lambda (opt name arg result)
(alist-cons 'optimize? #t result)))
@ -86,13 +99,27 @@ options."
;; default option values
'((input-files)
(load-path))))
(load-path)
(warnings unsupported-warning))))
(define (show-warning-help)
(format #t "The available warning types are:~%~%")
(for-each (lambda (wt)
(format #t " ~22A ~A~%"
(format #f "`~A'" (warning-type-name wt))
(warning-type-description wt)))
%warning-types)
(format #t "~%"))
(define (compile . args)
(let* ((options (parse-args args))
(help? (assoc-ref options 'help?))
(compile-opts (if (assoc-ref options 'optimize?) '(#:O) '()))
(compile-opts (let ((o `(#:warnings
,(assoc-ref options 'warnings))))
(if (assoc-ref options 'optimize?)
(cons #:O o)
o)))
(from (or (assoc-ref options 'from) 'scheme))
(to (or (assoc-ref options 'to) 'objcode))
(input-files (assoc-ref options 'input-files))
@ -108,6 +135,9 @@ Compile each Guile source file FILE into a Guile object.
-L, --load-path=DIR add DIR to the front of the module load path
-o, --output=OFILE write output to OFILE
-W, --warn=WARNING emit warnings of type WARNING; use `--warn=help'
for a list of available warnings
-f, --from=LANG specify a source language other than `scheme'
-t, --to=LANG specify a target language other than `objcode'

11
module/system/base/compile.scm
View file

@ -21,6 +21,7 @@
(define-module (system base compile)
#:use-module (system base syntax)
#:use-module (system base language)
#:use-module (system base message)
#:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
#:use-module (ice-9 regex)
#:use-module (ice-9 optargs)
@ -213,6 +214,16 @@
(from (current-language))
(to 'value)
(opts '()))
(let ((warnings (memq #:warnings opts)))
(if (pair? warnings)
(let ((warnings (cadr warnings)))
;; Sanity-check the requested warnings.
(for-each (lambda (w)
(or (lookup-warning-type w)
(warning 'unsupported-warning #f w)))
warnings))))
(receive (exp env cenv)
(compile-fold (compile-passes from to opts) x env opts)
exp))

102
module/system/base/message.scm Normal file
View file

@ -0,0 +1,102 @@
;;; User interface messages
;; 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
;;; Commentary:
;;;
;;; This module provide a simple interface to send messages to the user.
;;; TODO: Internationalize messages.
;;;
;;; Code:
(define-module (system base message)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:export (*current-warning-port* warning
warning-type? warning-type-name warning-type-description
warning-type-printer lookup-warning-type
%warning-types))
;;;
;;; Source location
;;;
(define (location-string loc)
(if (pair? loc)
(format #f "~a:~a:~a"
(or (assoc-ref loc 'filename) "<stdin>")
(1+ (assoc-ref loc 'line))
(assoc-ref loc 'column))
"<unknown-location>"))
;;;
;;; Warnings
;;;
(define *current-warning-port*
;; The port where warnings are sent.
(make-fluid))
(fluid-set! *current-warning-port* (current-error-port))
(define-record-type <warning-type>
(make-warning-type name description printer)
warning-type?
(name warning-type-name)
(description warning-type-description)
(printer warning-type-printer))
(define %warning-types
;; List of know warning types.
(map (lambda (args)
(apply make-warning-type args))
`((unsupported-warning ;; a "meta warning"
"warn about unknown warning types"
,(lambda (port unused name)
(format port "warning: unknown warning type `~A'~%"
name)))
(unused-variable
"report unused variables"
,(lambda (port loc name)
(format port "~A: warning: unused variable `~A'~%"
loc name))))))
(define (lookup-warning-type name)
"Return the warning type NAME or `#f' if not found."
(find (lambda (wt)
(eq? name (warning-type-name wt)))
%warning-types))
(define (warning type location . args)
"Emit a warning of type TYPE for source location LOCATION (a source
property alist) using the data in ARGS."
(let ((wt (lookup-warning-type type))
(port (fluid-ref *current-warning-port*)))
(if (warning-type? wt)
(apply (warning-type-printer wt)
port (location-string location)
args)
(format port "~A: unknown warning type `~A': ~A~%"
(location-string location) type args))))
;;; message.scm ends here

1
module/system/repl/command.scm
View file

@ -386,7 +386,6 @@ Trace execution.
-s Display stack
-l Display local variables
-e Display external variables
-b Bytecode level trace"
(apply vm-trace (repl-vm repl)
(repl-compile repl (repl-parse repl form))

47
module/system/vm/frame.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM frame functions
;;; Copyright (C) 2001 Free Software Foundation, Inc.
;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
;;;
;;; This program is free software; you can redistribute it and/or modify
@ -27,20 +27,20 @@
vm-frame-program
vm-frame-local-ref vm-frame-local-set!
vm-frame-return-address vm-frame-mv-return-address
vm-frame-dynamic-link vm-frame-external-link
vm-frame-dynamic-link
vm-frame-stack
vm-frame-number vm-frame-address
make-frame-chain
print-frame print-frame-chain-as-backtrace
frame-arguments frame-local-variables frame-external-variables
frame-environment
frame-variable-exists? frame-variable-ref frame-variable-set!
frame-object-name
frame-local-ref frame-external-link frame-local-set!
frame-return-address frame-program
frame-dynamic-link heap-frame?))
make-frame-chain
print-frame print-frame-chain-as-backtrace
frame-arguments frame-local-variables
frame-environment
frame-variable-exists? frame-variable-ref frame-variable-set!
frame-object-name
frame-local-ref frame-local-set!
frame-return-address frame-program
frame-dynamic-link heap-frame?))
(load-extension "libguile" "scm_init_frames")
@ -158,24 +158,19 @@
(l '() (cons (frame-local-ref frame n) l)))
((< n 0) l))))
(define (frame-external-variables frame)
(frame-external-link frame))
(define (frame-external-ref frame index)
(list-ref (frame-external-link frame) index))
(define (frame-external-set! frame index val)
(list-set! (frame-external-link frame) index val))
(define (frame-binding-ref frame binding)
(if (binding:extp binding)
(frame-external-ref frame (binding:index binding))
(frame-local-ref frame (binding:index binding))))
(let ((x (frame-local-ref frame (binding:index binding))))
(if (and (binding:boxed? binding) (variable? x))
(variable-ref x)
x)))
(define (frame-binding-set! frame binding val)
(if (binding:extp binding)
(frame-external-set! frame (binding:index binding) val)
(frame-local-set! frame (binding:index binding) val)))
(if (binding:boxed? binding)
(let ((v (frame-local-ref frame binding)))
(if (variable? v)
(variable-set! v val)
(frame-local-set! frame binding (make-variable val))))
(frame-local-set! frame binding val)))
;; FIXME handle #f program-bindings return
(define (frame-bindings frame addr)

17
module/system/vm/program.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM program functions
;;; 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
@ -21,9 +21,9 @@
(define-module (system vm program)
#:export (make-program
arity:nargs arity:nrest arity:nlocs arity:nexts
arity:nargs arity:nrest arity:nlocs
make-binding binding:name binding:extp binding:index
make-binding binding:name binding:boxed? binding:index
binding:start binding:end
source:addr source:line source:column source:file
@ -31,21 +31,20 @@
program-properties program-property program-documentation
program-name program-arguments
program-arity program-external-set! program-meta
program-arity program-meta
program-objcode program? program-objects
program-module program-base program-external))
program-module program-base program-free-variables))
(load-extension "libguile" "scm_init_programs")
(define arity:nargs car)
(define arity:nrest cadr)
(define arity:nlocs caddr)
(define arity:nexts cadddr)
(define (make-binding name extp index start end)
(list name extp index start end))
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
(define (binding:extp b) (list-ref b 1))
(define (binding:boxed? b) (list-ref b 1))
(define (binding:index b) (list-ref b 2))
(define (binding:start b) (list-ref b 3))
(define (binding:end b) (list-ref b 4))

5
module/system/vm/trace.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM tracer
;; 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
@ -54,8 +54,7 @@
((null? opts) (newline))
(case (car opts)
((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
((:l) (puts (vm-fetch-locals vm)))
((:e) (puts (vm-fetch-externals vm))))))
((:l) (puts (vm-fetch-locals vm))))))
(define (trace-apply vm)
(if (vm-option vm 'trace-first)