mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 23:00:22 +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))) && i < SCM_I_VECTOR_LENGTH (vect)))
RETURN (SCM_I_VECTOR_ELTS (vect)[i]); RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
else 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) 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))) && i < SCM_I_VECTOR_LENGTH (vect)))
SCM_I_VECTOR_WELTS (vect)[i] = val; SCM_I_VECTOR_WELTS (vect)[i] = val;
else else
scm_vector_set_x (vect, idx, val); {
SYNC_REGISTER ();
scm_vector_set_x (vect, idx, val);
}
NEXT; 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)) (with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda () (lambda ()
(values (flatten-lambda x allocation) (values (flatten-lambda x #f allocation)
(and e (cons (car e) (cddr e))) (and e (cons (car e) (cddr e)))
e))))) e)))))
@ -177,7 +177,7 @@
(proc emit-code) (proc emit-code)
(reverse out))) (reverse out)))
(define (flatten-lambda x allocation) (define (flatten-lambda x self-label allocation)
(receive (ids vars nargs nrest) (receive (ids vars nargs nrest)
(let lp ((ids (lambda-names x)) (vars (lambda-vars x)) (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
(oids '()) (ovars '()) (n 0)) (oids '()) (ovars '()) (n 0))
@ -193,6 +193,9 @@
nargs nrest nlocs (lambda-meta x) nargs nrest nlocs (lambda-meta x)
(with-output-to-code (with-output-to-code
(lambda (emit-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 ;; write bindings and source debugging info
(emit-bindings #f ids vars allocation x emit-code) (emit-bindings #f ids vars allocation x emit-code)
(if (lambda-src x) (if (lambda-src x)
@ -201,14 +204,14 @@
(for-each (for-each
(lambda (v) (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) x) (pmatch (hashq-ref (hashq-ref allocation v) x)
((#t #t . ,n) ((#t #t . ,n)
(emit-code #f (make-glil-lexical #t #f 'ref n)) (emit-code #f (make-glil-lexical #t #f 'ref n))
(emit-code #f (make-glil-lexical #t #t 'box n))))) (emit-code #f (make-glil-lexical #t #t 'box n)))))
vars) vars)
;; and here, here, dear reader: we compile. ;; 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) (define (emit-label label)
(emit-code #f (make-glil-label label))) (emit-code #f (make-glil-label label)))
(define (emit-branch src inst label) (define (emit-branch src inst label)
@ -384,6 +387,25 @@
(error "bad primitive op: too many pushes" (error "bad primitive op: too many pushes"
op (instruction-pushes op)))))) 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 (else
(comp-push proc) (comp-push proc)
(for-each comp-push args) (for-each comp-push args)
@ -442,7 +464,7 @@
((<lexical-ref> src name gensym) ((<lexical-ref> src name gensym)
(case context (case context
((push vals tail) ((push vals tail)
(pmatch (hashq-ref (hashq-ref allocation gensym) proc) (pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index) ((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'ref index))) (emit-code src (make-glil-lexical local? boxed? 'ref index)))
(,loc (,loc
@ -452,7 +474,7 @@
((<lexical-set> src name gensym exp) ((<lexical-set> src name gensym exp)
(comp-push exp) (comp-push exp)
(pmatch (hashq-ref (hashq-ref allocation gensym) proc) (pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index) ((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'set index))) (emit-code src (make-glil-lexical local? boxed? 'set index)))
(,loc (,loc
@ -510,7 +532,7 @@
(let ((free-locs (cdr (hashq-ref allocation x)))) (let ((free-locs (cdr (hashq-ref allocation x))))
(case context (case context
((push vals tail) ((push vals tail)
(emit-code #f (flatten-lambda x allocation)) (emit-code #f (flatten-lambda x #f allocation))
(if (not (null? free-locs)) (if (not (null? free-locs))
(begin (begin
(for-each (for-each
@ -527,9 +549,9 @@
((<let> src names vars vals body) ((<let> src names vars vals body)
(for-each comp-push vals) (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) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n) ((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n))) (emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n) ((#t #t . ,n)
@ -541,15 +563,15 @@
((<letrec> src names vars vals body) ((<letrec> src names vars vals body)
(for-each (lambda (v) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n) ((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'empty-box n))) (emit-code src (make-glil-lexical #t #t 'empty-box n)))
(,loc (error "badness" x loc)))) (,loc (error "badness" x loc))))
vars) vars)
(for-each comp-push vals) (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) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n) ((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'set n))) (emit-code src (make-glil-lexical #t #t 'set n)))
(,loc (error "badness" x loc)))) (,loc (error "badness" x loc))))
@ -563,20 +585,20 @@
;; set them to their local var slots first, then capture their ;; set them to their local var slots first, then capture their
;; bindings, mutating them in place. ;; bindings, mutating them in place.
(for-each (lambda (x v) (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)))) (if (not (null? (cdr (hashq-ref allocation x))))
;; But we do have to make-closure them first, so ;; But we do have to make-closure them first, so
;; we are mutating fresh closures on the heap. ;; we are mutating fresh closures on the heap.
(begin (begin
(emit-code #f (make-glil-const #f)) (emit-code #f (make-glil-const #f))
(emit-code #f (make-glil-call 'make-closure 2)))) (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) ((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n))) (emit-code src (make-glil-lexical #t #f 'set n)))
(,loc (error "badness" x loc)))) (,loc (error "badness" x loc))))
vals vals
vars) 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. ;; Now go back and fix up the bindings.
(for-each (for-each
(lambda (x v) (lambda (x v)
@ -591,7 +613,7 @@
(else (error "what" x loc)))) (else (error "what" x loc))))
free-locs) free-locs)
(emit-code #f (make-glil-call 'vector (length 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) ((#t #f . ,n)
(emit-code #f (make-glil-lexical #t #f 'fix n))) (emit-code #f (make-glil-lexical #t #f 'fix n)))
(,loc (error "badness" x loc))))))) (,loc (error "badness" x loc)))))))
@ -616,10 +638,10 @@
(emit-code #f (make-glil-const 1)) (emit-code #f (make-glil-const 1))
(emit-label MV) (emit-label MV)
(emit-code src (make-glil-mv-bind (emit-code src (make-glil-mv-bind
(vars->bind-list names vars allocation proc) (vars->bind-list names vars allocation self)
rest?)) rest?))
(for-each (lambda (v) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n) ((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n))) (emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n) ((#t #t . ,n)

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

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