mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 01:00:20 +02:00
Code Activity

remove useless <glil-vars> helper type, serialize GHIL more strictly

Browse source 
* module/language/ghil.scm (parse-ghil, unparse-ghil): Rework to make the
  parse format correspond more closely with the object representation, so
  that I only have to document it once in the manual. The salient change
  is that no expression is self-quoting, and that variable references
  should go through `(ref FOO)'. Rename `set!' to `set'.

* module/language/ghil/compile-glil.scm: Add a couple of compilers for
  unquote and unquote-splicing, that just raise an error. This way I can
  document unquote and unquote-splicing as normal ghil expressions,
  except that it's the compiler that catches them if they're outside a
  quasiquote.
  (codegen): Adapt to change in <glil-asm>.

* module/language/ghil/spec.scm (parse): Fix parser typo bug.

* module/language/glil.scm (<glil-asm>): Remove useless <glil-vars>
  structure, which also had a confusing name. Just put the nargs, nrest,
  nlocs, and nexts in the <glil-asm> directly.
  (parse-glil, unparse-glil): Serialize `asm' more straightforwardly.

* module/language/glil/compile-objcode.scm (<bytespec>): Remove
  <glil-vars>, as with <glil-asm>.
  (preprocess, make-meta, codegen, dump-object!): Adapt to change in
  <glil-asm>.
This commit is contained in:
Andy Wingo 2009-01-11 12:09:19 +01:00
parent ca445ba5ec
commit c2c82b62f4
5 changed files with 58 additions and 68 deletions
Download patch file Download diff file Expand all files Collapse all files

69
module/language/glil/compile-objcode.scm
View file

@ -46,7 +46,7 @@
(define-record <vlink-now> key)
(define-record <vlink-later> key)
(define-record <vdefine> name)
(define-record <bytespec> vars bytes meta objs closure?)
(define-record <bytespec> nargs nrest nlocs nexts bytes meta objs closure?)
;;;
@ -55,8 +55,8 @@
(define (preprocess x e)
(record-case x
((<glil-asm> vars meta body)
(let* ((venv (make-venv #:parent e #:nexts (glil-vars-nexts vars) #:closure? #f))
((<glil-asm> 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)
@ -89,7 +89,7 @@
(push (code->bytes code) stack))
(dump-object! push-code! `(,bindings ,sources ,@tail))
(push-code! '(return))
(make-bytespec #:vars (make-glil-vars 0 0 0 0)
(make-bytespec #:nargs 0 #:nrest 0 #:nlocs 0 #:nexts 0
#:bytes (stack->bytes (reverse! stack) '())
#:meta #f #:objs #f #:closure? #f))))
@ -109,7 +109,7 @@
(define (codegen glil toplevel)
(record-case glil
((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body?
((<vm-asm> venv glil body) (record-case glil ((<glil-asm> nargs nrest nlocs nexts meta) ; body?
(let ((stack '())
(open-bindings '())
(closed-bindings '())
@ -168,11 +168,11 @@
(push-object! (codegen x #f))
(if (venv-closure? venv) (push-code! `(make-closure))))
((<glil-bind> (binds vars))
(push-bindings! (munge-bindings binds (glil-vars-nargs vars))))
((<glil-bind> vars)
(push-bindings! (munge-bindings vars nargs)))
((<glil-mv-bind> (binds vars) rest)
(push-bindings! (munge-bindings binds (glil-vars-nargs vars)))
((<glil-mv-bind> vars rest)
(push-bindings! (munge-bindings vars nargs))
(push-code! `(truncate-values ,(length binds) ,(if rest 1 0))))
((<glil-unbind>)
@ -194,8 +194,8 @@
((<glil-local> op index)
(if (eq? op 'ref)
(push-code! `(local-ref ,(+ (glil-vars-nargs vars) index)))
(push-code! `(local-set ,(+ (glil-vars-nargs vars) index)))))
(push-code! `(local-ref ,(+ nargs index)))
(push-code! `(local-set ,(+ nargs index)))))
((<glil-external> op depth index)
(do ((e venv (venv-parent e))
@ -281,8 +281,9 @@
; (format #t "codegen: stack = ~a~%" (reverse stack))
(let ((bytes (stack->bytes (reverse! stack) label-alist)))
(if toplevel
(bytecode->objcode bytes (glil-vars-nlocs vars) (glil-vars-nexts vars))
(make-bytespec #:vars vars #:bytes bytes
(bytecode->objcode bytes nlocs nexts)
(make-bytespec #:nargs nargs #:nrest nrest #:nlocs nlocs
#:nexts nexts #:bytes bytes
#:meta (make-meta closed-bindings
(reverse! source-alist)
meta)
@ -343,28 +344,26 @@
((object->code x) => push-code!)
((record? x)
(record-case x
((<bytespec> vars bytes meta objs closure?)
;; dump parameters
(let ((nargs (glil-vars-nargs vars)) (nrest (glil-vars-nrest vars))
(nlocs (glil-vars-nlocs vars)) (nexts (glil-vars-nexts vars)))
(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)))))
((<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