mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

loop detection in the house

Browse source 
* libguile/vm-i-scheme.c (vector-ref, vector-set): Sync registers if we
  call out to C.

* module/language/tree-il/compile-glil.scm (flatten-lambda): Add an
  extra argument, the self-label, which should be the gensym under which
  the procedure is bound in a <fix> expression.
  (flatten): If we see a call to a lexical ref to the self-label in a
  tail position, rename and goto instead of goto/args, which will tear
  down the frame -- or will, in the future. It's a primitive form of
  loop detection.

* module/language/tree-il/primitives.scm (zero?): Expand to (= x 0).
This commit is contained in:
Andy Wingo 2009-08-06 17:46:38 +02:00
parent 80af116875
commit 9b29d60791
3 changed files with 54 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

10
libguile/vm-i-scheme.c
View file

@ -315,7 +315,10 @@ VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
&& i < SCM_I_VECTOR_LENGTH (vect)))
RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
else
RETURN (scm_vector_ref (vect, idx));
{
SYNC_REGISTER ();
RETURN (scm_vector_ref (vect, idx));
}
}
VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
@ -329,7 +332,10 @@ VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
&& i < SCM_I_VECTOR_LENGTH (vect)))
SCM_I_VECTOR_WELTS (vect)[i] = val;
else
scm_vector_set_x (vect, idx, val);
{
SYNC_REGISTER ();
scm_vector_set_x (vect, idx, val);
}
NEXT;
}

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

@ -66,7 +66,7 @@
(with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda ()
(values (flatten-lambda x allocation)
(values (flatten-lambda x #f allocation)
(and e (cons (car e) (cddr e)))
e)))))
@ -177,7 +177,7 @@
(proc emit-code)
(reverse out)))
(define (flatten-lambda x allocation)
(define (flatten-lambda x self-label allocation)
(receive (ids vars nargs nrest)
(let lp ((ids (lambda-names x)) (vars (lambda-vars x))
(oids '()) (ovars '()) (n 0))
@ -193,6 +193,9 @@
nargs nrest nlocs (lambda-meta x)
(with-output-to-code
(lambda (emit-code)
;; emit label for self tail calls
(if self-label
(emit-code #f (make-glil-label self-label)))
;; write bindings and source debugging info
(emit-bindings #f ids vars allocation x emit-code)
(if (lambda-src x)
@ -201,14 +204,14 @@
(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)))))
((#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) allocation x emit-code)))))))
(flatten (lambda-body x) allocation x self-label emit-code)))))))
(define (flatten x allocation proc emit-code)
(define (flatten x allocation self self-label emit-code)
(define (emit-label label)
(emit-code #f (make-glil-label label)))
(define (emit-branch src inst label)
@ -384,6 +387,25 @@
(error "bad primitive op: too many pushes"
op (instruction-pushes op))))))
;; da capo al fine
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
;; self-call in tail position is a goto
(eq? context 'tail)
;; make sure the arity is right
(list? (lambda-vars self))
(= (length args) (length (lambda-vars self))))
;; evaluate new values
(for-each comp-push args)
;; rename & goto
(for-each (lambda (sym)
(pmatch (hashq-ref (hashq-ref allocation sym) self)
((#t ,boxed? . ,index)
(emit-code #f (make-glil-lexical #t #f 'set index)))
(,x (error "what" x))))
(reverse (lambda-vars self)))
(emit-branch src 'br self-label))
(else
(comp-push proc)
(for-each comp-push args)
@ -442,7 +464,7 @@
((<lexical-ref> src name gensym)
(case context
((push vals tail)
(pmatch (hashq-ref (hashq-ref allocation gensym) proc)
(pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'ref index)))
(,loc
@ -452,7 +474,7 @@
((<lexical-set> src name gensym exp)
(comp-push exp)
(pmatch (hashq-ref (hashq-ref allocation gensym) proc)
(pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'set index)))
(,loc
@ -510,7 +532,7 @@
(let ((free-locs (cdr (hashq-ref allocation x))))
(case context
((push vals tail)
(emit-code #f (flatten-lambda x allocation))
(emit-code #f (flatten-lambda x #f allocation))
(if (not (null? free-locs))
(begin
(for-each
@ -527,9 +549,9 @@
((<let> src names vars vals body)
(for-each comp-push vals)
(emit-bindings src names vars allocation proc emit-code)
(emit-bindings src names vars allocation self emit-code)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n)
@ -541,15 +563,15 @@
((<letrec> src names vars vals body)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#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)
(emit-bindings src names vars allocation self emit-code)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'set n)))
(,loc (error "badness" x loc))))
@ -563,20 +585,20 @@
;; set them to their local var slots first, then capture their
;; bindings, mutating them in place.
(for-each (lambda (x v)
(emit-code #f (flatten-lambda x allocation))
(emit-code #f (flatten-lambda x v allocation))
(if (not (null? (cdr (hashq-ref allocation x))))
;; But we do have to make-closure them first, so
;; we are mutating fresh closures on the heap.
(begin
(emit-code #f (make-glil-const #f))
(emit-code #f (make-glil-call 'make-closure 2))))
(pmatch (hashq-ref (hashq-ref allocation v) proc)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
(,loc (error "badness" x loc))))
vals
vars)
(emit-bindings src names vars allocation proc emit-code)
(emit-bindings src names vars allocation self emit-code)
;; Now go back and fix up the bindings.
(for-each
(lambda (x v)
@ -591,7 +613,7 @@
(else (error "what" x loc))))
free-locs)
(emit-code #f (make-glil-call 'vector (length free-locs)))
(pmatch (hashq-ref (hashq-ref allocation v) proc)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code #f (make-glil-lexical #t #f 'fix n)))
(,loc (error "badness" x loc)))))))
@ -616,10 +638,10 @@
(emit-code #f (make-glil-const 1))
(emit-label MV)
(emit-code src (make-glil-mv-bind
(vars->bind-list names vars allocation proc)
(vars->bind-list names vars allocation self)
rest?))
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n)

3
module/language/tree-il/primitives.scm
View file

@ -200,6 +200,9 @@
(cons `((src . ,(car in))
,(consequent (cadr in))) out)))))))
(define-primitive-expander zero? (x)
(= x 0))
(define-primitive-expander +
() 0
(x) x