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

procedures-with-setters, debitrot `optimize', dedottification

Browse source 
* module/system/base/syntax.scm (define-record): Define the accessors as
  procedures-with-setters, not just as getters.

* module/system/il/compile.scm (optimize): This function was bitrotten
  since the addition of source locations in
  cb4cca12e7. Untested attempts to
  de-bitrot it. Dedottify as well.

* module/system/il/ghil.scm:
* module/system/il/glil.scm (unparse):
* module/system/vm/debug.scm (debugger-repl): Ongoing dedottification.
This commit is contained in:
Andy Wingo 2008-05-04 15:37:54 +02:00
parent 9f8ec6eb1f
commit 61dc81d993
5 changed files with 60 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

12
module/system/base/syntax.scm
View file

@ -93,13 +93,15 @@
(and (vector? x) (eq? (vector-ref x 0) ',name)))
,@(do ((n 1 (1+ n))
(slots (cdr def) (cdr slots))
(ls '() (append (let* ((slot (car slots))
(slot (if (pair? slot) (car slot) slot)))
(ls '() (append (let* ((sdef (car slots))
(sname (if (pair? sdef) (car sdef) sdef)))
`((define ,(string->symbol
(format #f "~A-~A" name n))
(lambda (x) (slot x ',slot)))
(define ,(symbol-append stem '- slot)
(lambda (x) (slot x ',slot)))))
(lambda (x) (slot x ',sname)))
(define ,(symbol-append stem '- sname)
,(make-procedure-with-setter
(lambda (x) (get-slot x sname))
(lambda (x v) (set-slot! x sname v))))))
ls)))
((null? slots) (reverse! ls))))))

42
module/system/il/compile.scm
View file

@ -37,38 +37,44 @@
(define (optimize x)
(record-case x
((<ghil-set> env var val)
((<ghil-set> env loc var val)
(make-ghil-set env var (optimize val)))
((<ghil-if> test then else)
((<ghil-if> env loc test then else)
(make-ghil-if (optimize test) (optimize then) (optimize else)))
((<ghil-begin> exps)
((<ghil-begin> env loc exps)
(make-ghil-begin (map optimize exps)))
((<ghil-bind> env vars vals body)
((<ghil-bind> env loc vars vals body)
(make-ghil-bind env vars (map optimize vals) (optimize body)))
((<ghil-lambda> env vars rest body)
((<ghil-lambda> env loc vars rest body)
(make-ghil-lambda env vars rest (optimize body)))
;; FIXME: <ghil-inst> does not exist. -- Ludo'.
; (($ <ghil-inst> inst args)
; (make-ghil-inst inst (map optimize args)))
((<ghil-call> env proc args)
(record-case proc
;; ((@lambda (VAR...) BODY...) ARG...) =>
;; (@let ((VAR ARG) ...) BODY...)
((<ghil-lambda> lambda-env vars #f body)
(for-each (lambda (v)
(if (eq? v.kind 'argument) (set! v.kind 'local))
(set! v.env env)
(ghil-env-add! env v))
lambda-env.variables)
(optimize (make-ghil-bind env vars args body)))
(else
(make-ghil-call env (optimize proc) (map optimize args)))))
((<ghil-call> env loc proc args)
(let ((parent-env env))
(record-case proc
;; ((@lambda (VAR...) BODY...) ARG...) =>
;; (@let ((VAR ARG) ...) BODY...)
((<ghil-lambda> env loc vars rest body)
(cond
((not rest)
(for-each (lambda (v)
(case (ghil-var-kind v)
((argument) (set! (ghil-var-kind v) 'local)))
(set! (ghil-var-env v) parent-env)
(ghil-env-add! parent-env v))
(ghil-env-variables env)))
(else
(make-ghil-call parent-env (optimize proc) (map optimize args)))))
(else
(make-ghil-call parent-env (optimize proc) (map optimize args))))))
(else x)))

40
module/system/il/ghil.scm
View file

@ -61,7 +61,6 @@
ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
<ghil-lambda> make-ghil-lambda <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
<ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5
ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest ghil-lambda-body
<ghil-inline> make-ghil-inline <ghil-inline>?
<ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4
@ -152,34 +151,45 @@
((<ghil-env> m) (%make-ghil-env :mod m :parent e))))
(define (ghil-env-toplevel? e)
(eq? e.mod e.parent))
(eq? (ghil-env-mod e) (gil-env-parent e)))
(define (ghil-env-ref env sym)
(assq-ref env.table sym))
(assq-ref (ghil-env-table env) sym))
(define-macro (push! item loc)
`(set! ,loc (cons ,item ,loc)))
(define-macro (apush! k v loc)
`(set! ,loc (acons ,k ,v ,loc)))
(define-macro (apopq! k loc)
`(set! ,loc (assq-remove! ,k ,loc)))
(define-public (ghil-env-add! env var)
(set! env.table (acons var.name var env.table))
(set! env.variables (cons var env.variables)))
(apush! (ghil-var-name var) var (ghil-env-table env))
(push! var (ghil-env-variables env)))
(define (ghil-env-remove! env var)
(set! env.table (assq-remove! env.table var.name)))
(apopq! (ghil-var-name var) (ghil-env-table env)))
;;;
;;; Public interface
;;;
;; looking up a var has side effects?
(define-public (ghil-lookup env sym)
(or (ghil-env-ref env sym)
(let loop ((e env.parent))
(cond ((<ghil-mod>? e)
(or (assq-ref e.table sym)
(let ((var (make-ghil-var #f sym 'module)))
(set! e.table (acons sym var e.table))
var)))
((ghil-env-ref e sym) =>
(lambda (var) (set! var.kind 'external) var))
(else (loop e.parent))))))
(let loop ((e (ghil-env-parent env)))
(record-case e
((<ghil-mod> module table imports)
(or (assq-ref table sym)
(let ((var (make-ghil-var #f sym 'module)))
(apush! sym var (ghil-mod-table e))
var)))
((<ghil-env> mod parent table variables)
(let ((found (assq-ref table sym)))
(if found
(begin (set! (ghil-var-kind found) 'external) found)
(loop parent))))))))
(define-public (call-with-ghil-environment e syms func)
(let* ((e (make-ghil-env e))

3
module/system/il/glil.scm
View file

@ -157,7 +157,8 @@
(record-case glil
;; meta
((<glil-asm> vars body)
`(@asm (,vars.nargs ,vars.nrest ,vars.nlocs ,vars.nexts)
`(@asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
,@(map unparse body)))
((<glil-bind> vars) `(@bind ,@vars))
((<glil-unbind>) `(@unbind))

4
module/system/vm/debug.scm
View file

@ -46,9 +46,9 @@
(display "debug> ")
(let ((cmd (read)))
(case cmd
((bt) (vm-backtrace db.vm))
((bt) (vm-backtrace (debugger-vm db)))
((stack)
(write (vm-fetch-stack db.vm))
(write (vm-fetch-stack (debugger-vm db)))
(newline))
(else
(format #t "Unknown command: ~A" cmd))))))