mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +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

17
module/language/ghil.scm
View file

@ -349,11 +349,8 @@
(let ((loc (location exp))
(retrans (lambda (x) (parse-ghil env x))))
(pmatch exp
(,exp (guard (symbol? exp))
(make-ghil-ref env #f (ghil-var-for-ref! env exp)))
(,exp (guard (not (pair? exp)))
(make-ghil-quote #:env env #:loc #f #:obj exp))
((ref ,sym) (guard (symbol? sym))
(make-ghil-ref env #f (ghil-var-for-ref! env sym)))
(('quote ,exp) (make-ghil-quote #:env env #:loc loc #:obj exp))
@ -380,7 +377,7 @@
(let ((vals (map (lambda (exp) (parse-ghil env exp)) exprs)))
(make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
((set! ,sym ,val)
((set ,sym ,val)
(make-ghil-set env loc (ghil-var-for-set! env sym) (retrans val)))
((define ,sym ,val)
@ -430,9 +427,7 @@
((<ghil-void> env loc)
'(void))
((<ghil-quote> env loc obj)
(if (symbol? obj)
`(,'quote ,obj)
obj))
`(,'quote ,obj))
((<ghil-quasiquote> env loc exp)
`(,'quasiquote ,(map unparse-ghil exp)))
((<ghil-unquote> env loc exp)
@ -441,9 +436,9 @@
`(,'unquote-splicing ,(unparse-ghil exp)))
;; Variables
((<ghil-ref> env loc var)
(ghil-var-name var))
`(ref ,(ghil-var-name var)))
((<ghil-set> env loc var val)
`(set! ,(ghil-var-name var) ,(unparse-ghil val)))
`(set ,(ghil-var-name var) ,(unparse-ghil val)))
((<ghil-define> env loc var val)
`(define ,(ghil-var-name var) ,(unparse-ghil val)))
;; Controls

14
module/language/ghil/compile-glil.scm
View file

@ -216,6 +216,12 @@
(maybe-drop)
(maybe-return))
((<ghil-unquote> env loc exp)
(error "unquote outside of quasiquote" exp))
((<ghil-unquote-splicing> env loc exp)
(error "unquote-splicing outside of quasiquote" exp))
((<ghil-ref> env loc var)
(return-code! loc (make-glil-var 'ref env var)))
@ -428,11 +434,9 @@
;; compile body
(comp body #t #f)
;; create GLIL
(let ((vars (make-glil-vars #:nargs (length vars)
#:nrest (if rest 1 0)
#:nlocs (length locs)
#:nexts (length exts))))
(make-glil-asm vars meta (reverse! stack))))))))
(make-glil-asm
(length vars) (if rest 1 0) (length locs) (length exts)
meta (reverse! stack)))))))
(define (finalize-index! list)
(do ((n 0 (1+ n))

2
module/language/ghil/spec.scm
View file

@ -31,7 +31,7 @@
(apply write (unparse-ghil exp) port))
(define (parse x)
(call-with-ghil-environment (make-ghil-toplevel-env e) '()
(call-with-ghil-environment (make-ghil-toplevel-env (current-module)) '()
(lambda (env vars)
(make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))

24
module/language/glil.scm
View file

@ -23,11 +23,9 @@
#:use-module (system base syntax)
#:use-module (system base pmatch)
#:export
(<glil-vars> make-glil-vars
glil-vars-nargs glil-vars-nrest glil-vars-nlocs glil-vars-nexts
<glil-asm> make-glil-asm glil-asm?
glil-asm-vars glil-asm-meta glil-asm-body
(<glil-asm> make-glil-asm glil-asm?
glil-asm-nargs glil-asm-nrest glil-asm-nlocs glil-asm-nexts
glil-asm-meta glil-asm-body
<glil-bind> make-glil-bind glil-bind?
glil-bind-vars
@ -74,14 +72,12 @@
parse-glil unparse-glil))
(define-record <glil-vars> nargs nrest nlocs nexts)
(define (print-glil x port)
(format port "#<glil ~s>" (unparse-glil x)))
(define-type (<glil> #:printer print-glil)
;; Meta operations
(<glil-asm> vars meta body)
(<glil-asm> nargs nrest nlocs nexts meta body)
(<glil-bind> vars)
(<glil-mv-bind> vars rest)
(<glil-unbind>)
@ -104,9 +100,8 @@
(define (parse-glil x)
(pmatch x
((asm (,nargs ,nrest ,nlocs ,next) ,meta . ,body)
(make-glil-asm (make-glil-vars nargs nrest nlocs next)
meta (map parse-glil body)))
((asm ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
(make-glil-asm nargs nrest nlocs nexts meta (map parse-glil body)))
((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars . ,rest) (make-glil-mv-bind vars (map parse-glil rest)))
((unbind) (make-glil-unbind))
@ -128,11 +123,8 @@
(define (unparse-glil glil)
(record-case glil
;; meta
((<glil-asm> vars meta body)
`(asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
,meta
,@(map unparse-glil body)))
((<glil-asm> nargs nrest nlocs nexts meta body)
`(asm ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,@rest))
((<glil-unbind>) `(unbind))

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