[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-197-gb8a56
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-197-gb8a5606 |
|
Date: |
Thu, 05 Jul 2012 18:46:15 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b8a5606b1018578f5fd887e30adc9d6dd1160137
The branch, stable-2.0 has been updated
via b8a5606b1018578f5fd887e30adc9d6dd1160137 (commit)
via 997ed30070b0c6559abf6dc748a27ae286179dd4 (commit)
via 37081d5d4b2d5093a339ee33f94d9e47deb1c346 (commit)
via 3d2bcd2c350384ffaf96b79fa6096c9d77ea113e (commit)
via c0cfa9ef07aad3afef822d1afe1786eb655bd121 (commit)
via 21b83fb7953fd2b5e40ca9206a0a72ec3cb2489e (commit)
from 8898f43cb2044df4f0c1125028f472b47df20828 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit b8a5606b1018578f5fd887e30adc9d6dd1160137
Author: Andy Wingo <address@hidden>
Date: Thu Jul 5 20:40:56 2012 +0200
fix-letrec uses effects.scm for effects analysis
* module/language/tree-il/fix-letrec.scm: Use effects.scm for effects
analysis, instead of primitives.scm.
(simple-expression?, partition-vars): Adapt.
commit 997ed30070b0c6559abf6dc748a27ae286179dd4
Author: Andy Wingo <address@hidden>
Date: Thu Jul 5 20:39:16 2012 +0200
simplify one kind of degenerate prompt
* module/language/tree-il/peval.scm (<operand>): Instead of having a
`residualize?' field, have it be a use count.
(peval): Adapt to <operand> change. Add function to kill uses of an
operand. Use it in the <prompt> inliner. Add another kind of
degenerate prompt to elide. We should really switch to CPS though, as
that will allow us to contify more aggressively.
* test-suite/tests/peval.test ("partial evaluation"): Adapt (while #t
#t) test, which was sensitive to how far the recursive inlining got.
Add a test for the degenerate prompt elision.
commit 37081d5d4b2d5093a339ee33f94d9e47deb1c346
Author: Andy Wingo <address@hidden>
Date: Thu Jul 5 20:34:28 2012 +0200
fix bugs in effects analysis of "effect+exception-free-primitives"
* module/language/tree-il/effects.scm (make-effects-analyzer): Be more
precise regarding the effects of the so-called
effect+exception-free-primitives: now we check their arities.
* test-suite/tests/cse.test ("cse"): Add a test that we don't
elide (cons 1 2 3) in effect context.
commit 3d2bcd2c350384ffaf96b79fa6096c9d77ea113e
Author: Andy Wingo <address@hidden>
Date: Thu Jul 5 20:30:18 2012 +0200
optimize (apply foo 0 (list 1 2)) => (foo 0 1 2)
* module/language/tree-il/peval.scm (peval): Inline applications where
we know the contents of the tail.
* test-suite/tests/peval.test ("partial evaluation"): Add tests.
commit c0cfa9ef07aad3afef822d1afe1786eb655bd121
Author: Andy Wingo <address@hidden>
Date: Thu Jul 5 11:06:29 2012 +0200
compile ecmascript's `return' as an abort
* module/language/ecmascript/compile-tree-il.scm (current-return-tag):
(with-return-prompt, comp): Compile `return' as an abort instead of a
primcall to `return'. Fixes beta-reduction by the optimizer -- it
doesn't make sense for `return' to move from one function to another!
commit 21b83fb7953fd2b5e40ca9206a0a72ec3cb2489e
Author: Andy Wingo <address@hidden>
Date: Thu Jul 5 10:15:02 2012 +0200
fix goops compilation when current language is not scheme
* module/oop/goops/dispatch.scm (compute-dispatch-procedure): Set source
language to Scheme, not (current-language).
-----------------------------------------------------------------------
Summary of changes:
module/language/ecmascript/compile-tree-il.scm | 27 +++++-
module/language/tree-il/effects.scm | 33 +++++-
module/language/tree-il/fix-letrec.scm | 34 ++++---
module/language/tree-il/peval.scm | 124 +++++++++++++++++++-----
module/oop/goops/dispatch.scm | 1 +
test-suite/tests/cse.test | 8 ++-
test-suite/tests/peval.test | 46 ++++++---
7 files changed, 214 insertions(+), 59 deletions(-)
diff --git a/module/language/ecmascript/compile-tree-il.scm
b/module/language/ecmascript/compile-tree-il.scm
index a2401f4..b5f0a35 100644
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -70,6 +70,26 @@
(set-source-properties! res (location x))))
res)))
+(define current-return-tag (make-parameter #f))
+
+(define (return expr)
+ (-> (abort (or (current-return-tag) (error "return outside function"))
+ (list expr)
+ (-> (const '())))))
+
+(define (with-return-prompt body-thunk)
+ (let ((tag (gensym "return")))
+ (parameterize ((current-return-tag
+ (-> (lexical 'return tag))))
+ (-> (let '(return) (list tag)
+ (list (-> (apply (-> (primitive 'make-prompt-tag)))))
+ (-> (prompt (current-return-tag)
+ (body-thunk)
+ (let ((val (gensym "val")))
+ (-> (lambda-case
+ `(((k val) #f #f #f () (,(gensym) ,val))
+ ,(-> (lexical 'val val)))))))))))))
+
(define (comp x e)
(let ((l (location x)))
(define (let1 what proc)
@@ -330,7 +350,9 @@
`(lambda ()
(lambda-case
((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*))
formals) ,syms)
- ,(comp-body e body formals syms))))))
+ ,(with-return-prompt
+ (lambda ()
+ (comp-body e body formals syms))))))))
((call/this ,obj ,prop . ,args)
(@impl call/this*
obj
@@ -352,8 +374,7 @@
`(apply ,(comp proc e)
,@(map (lambda (x) (comp x e)) args)))
((return ,expr)
- (-> (apply (-> (primitive 'return))
- (comp expr e))))
+ (return (comp expr e)))
((array . ,args)
`(apply ,(@implv new-array)
,@(map (lambda (x) (comp x e)) args)))
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
index 656b262..4610f7f 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -264,13 +264,34 @@ of an expression."
;; Effect-free primitives.
(($ <application> _
- ($ <primitive-ref> _ (and name
- (? effect+exception-free-primitive?)))
+ ($ <primitive-ref> _ (or 'values 'eq? 'eqv? 'equal?))
args)
- (logior (accumulate-effects args)
- (if (constructor-primitive? name)
- (cause &allocation)
- &no-effects)))
+ (accumulate-effects args))
+
+ (($ <application> _
+ ($ <primitive-ref> _ (or 'not 'pair? 'null? 'list? 'symbol?
+ 'vector? 'struct? 'string? 'number?
+ 'char?))
+ (arg))
+ (compute-effects arg))
+
+ ;; Primitives that allocate memory.
+ (($ <application> _ ($ <primitive-ref> _ 'cons) (x y))
+ (logior (compute-effects x) (compute-effects y)
+ &allocation))
+
+ (($ <application> _ ($ <primitive-ref> _ (or 'list 'vector)) args)
+ (logior (accumulate-effects args) &allocation))
+
+ (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ())
+ &allocation)
+
+ (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) (arg))
+ (logior (compute-effects arg) &allocation))
+
+ ;; Primitives that are normally effect-free, but which might
+ ;; cause type checks, allocate memory, or access mutable
+ ;; memory. FIXME: expand, to be more precise.
(($ <application> _
($ <primitive-ref> _ (and name
(? effect-free-primitive?)))
diff --git a/module/language/tree-il/fix-letrec.scm
b/module/language/tree-il/fix-letrec.scm
index 0a21d14..60c87e3 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -21,7 +21,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language tree-il)
- #:use-module (language tree-il primitives)
+ #:use-module (language tree-il effects)
#:export (fix-letrec!))
;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
@@ -31,25 +31,24 @@
(define fix-fold
(make-tree-il-folder unref ref set simple lambda complex))
-(define (simple-expression? x bound-vars simple-primitive?)
+(define (simple-expression? x bound-vars simple-primcall?)
(record-case x
((<void>) #t)
((<const>) #t)
((<lexical-ref> gensym)
(not (memq gensym bound-vars)))
((<conditional> test consequent alternate)
- (and (simple-expression? test bound-vars simple-primitive?)
- (simple-expression? consequent bound-vars simple-primitive?)
- (simple-expression? alternate bound-vars simple-primitive?)))
+ (and (simple-expression? test bound-vars simple-primcall?)
+ (simple-expression? consequent bound-vars simple-primcall?)
+ (simple-expression? alternate bound-vars simple-primcall?)))
((<sequence> exps)
- (and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
+ (and-map (lambda (x) (simple-expression? x bound-vars simple-primcall?))
exps))
((<application> proc args)
(and (primitive-ref? proc)
- (simple-primitive? (primitive-ref-name proc))
- ;; FIXME: check arity?
+ (simple-primcall? x)
(and-map (lambda (x)
- (simple-expression? x bound-vars simple-primitive?))
+ (simple-expression? x bound-vars simple-primcall?))
args)))
(else #f)))
@@ -92,6 +91,17 @@
(lambda (x unref ref set simple lambda* complex)
(record-case x
((<letrec> in-order? (orig-gensyms gensyms) vals)
+ (define compute-effects
+ (make-effects-analyzer (lambda (x) (memq x set))))
+ (define (effect-free-primcall? x)
+ (let ((effects (compute-effects x)))
+ (effect-free?
+ (exclude-effects effects (logior &allocation
+ &type-check)))))
+ (define (effect+exception-free-primcall? x)
+ (let ((effects (compute-effects x)))
+ (effect-free?
+ (exclude-effects effects &allocation))))
(let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '()))
(cond
@@ -114,7 +124,7 @@
(not (lambda? (car vals)))
(not (simple-expression?
(car vals) orig-gensyms
- effect+exception-free-primitive?)))
+ effect+exception-free-primcall?)))
(lp (cdr gensyms) (cdr vals)
s l (cons (car gensyms) c))
(lp (cdr gensyms) (cdr vals)
@@ -128,8 +138,8 @@
((simple-expression?
(car vals) orig-gensyms
(if in-order?
- effect+exception-free-primitive?
- effect-free-primitive?))
+ effect+exception-free-primcall?
+ effect-free-primcall?))
;; For letrec*, we can't consider e.g. `car' to be
;; "simple", as it could raise an exception. Hence
;; effect+exception-free-primitive? above.
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 15c7164..81921e3 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -288,7 +288,7 @@
;; TODO: Record value size in operand structure?
;;
(define-record-type <operand>
- (%make-operand var sym visit source visit-count residualize?
+ (%make-operand var sym visit source visit-count use-count
copyable? residual-value constant-value alias-value)
operand?
(var operand-var)
@@ -296,7 +296,7 @@
(visit %operand-visit)
(source operand-source)
(visit-count operand-visit-count set-operand-visit-count!)
- (residualize? operand-residualize? set-operand-residualize?!)
+ (use-count operand-use-count set-operand-use-count!)
(copyable? operand-copyable? set-operand-copyable?!)
(residual-value operand-residual-value %set-operand-residual-value!)
(constant-value operand-constant-value set-operand-constant-value!)
@@ -308,7 +308,7 @@
;; expression, truncate it to one value. Copy propagation does not
;; work on multiply-valued expressions.
(let ((source (and=> source truncate-values)))
- (%make-operand var sym visit source 0 #f
+ (%make-operand var sym visit source 0 0
(and source (not (var-set? var))) #f #f
(and (not (var-set? var)) alias))))
@@ -457,9 +457,18 @@ top-level bindings from ENV and return the resulting
expression."
(let ((x (vhash-assq new store)))
(if x (cdr x) new)))
+ (define (record-operand-use op)
+ (set-operand-use-count! op (1+ (operand-use-count op))))
+
+ (define (unrecord-operand-uses op n)
+ (let ((count (- (operand-use-count op) n)))
+ (when (zero? count)
+ (set-operand-residual-value! op #f))
+ (set-operand-use-count! op count)))
+
(define* (residualize-lexical op #:optional ctx val)
(log 'residualize op)
- (set-operand-residualize?! op #t)
+ (record-operand-use op)
(if (memq ctx '(value values))
(set-operand-residual-value! op val))
(make-lexical-ref #f (var-name (operand-var op)) (operand-sym op)))
@@ -605,7 +614,8 @@ top-level bindings from ENV and return the resulting
expression."
;; marked as needing residualization. Here we hack around this
;; and treat all bindings as referenced if we are in operator
;; context.
- (or (eq? ctx 'operator) (operand-residualize? op)))
+ (or (eq? ctx 'operator)
+ (not (zero? (operand-use-count op)))))
;; values := (op ...)
;; effects := (op ...)
@@ -819,7 +829,7 @@ top-level bindings from ENV and return the resulting
expression."
exp
(make-sequence src (list exp (make-void #f)))))
(begin
- (set-operand-residualize?! op #t)
+ (record-operand-use op)
(make-lexical-set src name (operand-sym op) (for-value exp))))))
(($ <let> src names gensyms vals body)
(define (compute-alias exp)
@@ -1094,6 +1104,17 @@ top-level bindings from ENV and return the resulting
expression."
(every singly-valued-expression? vals))
(for-tail (make-sequence src (append (cdr vals) (list (car
vals)))))
(make-application src (make-primitive-ref #f 'values) vals))))))
+ (($ <application> src (and apply ($ <primitive-ref> _ (or 'apply
'@apply)))
+ (proc args ... tail))
+ (match (for-value tail)
+ (($ <const> _ (args* ...))
+ (let ((args* (map (lambda (x) (make-const #f x)) args*)))
+ (for-tail (make-application src proc (append args args*)))))
+ (($ <application> _ ($ <primitive-ref> _ 'list) args*)
+ (for-tail (make-application src proc (append args args*))))
+ (tail
+ (let ((args (append (map for-value args) (list tail))))
+ (make-application src apply (cons (for-value proc) args))))))
(($ <application> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
(let ((proc (visit orig-proc 'operator)))
@@ -1346,25 +1367,80 @@ top-level bindings from ENV and return the resulting
expression."
(else
(lp rest (cons head effects)))))))))
(($ <prompt> src tag body handler)
- (define (singly-used-definition x)
+ (define (make-prompt-tag? x)
+ (match x
+ (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
+ (or () ((? constant-expression?))))
+ #t)
+ (_ #f)))
+ (define (find-definition x n-aliases)
(cond
- ((and (lexical-ref? x)
- ;; Only fetch definitions with single uses.
- (= (lexical-refcount (lexical-ref-gensym x)) 1)
- (lookup (lexical-ref-gensym x)))
- => (lambda (x)
- (singly-used-definition (visit-operand x counter 'value 10
10))))
- (else x)))
- (match (singly-used-definition tag)
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
- (or () ((? constant-expression?))))
- ;; There is no way that an <abort> could know the tag
- ;; for this <prompt>, so we can elide the <prompt>
- ;; entirely.
- (for-tail body))
- (_
- (make-prompt src (for-value tag) (for-tail body)
- (for-value handler)))))
+ ((lexical-ref? x)
+ (cond
+ ((lookup (lexical-ref-gensym x))
+ => (lambda (op)
+ (let ((y (or (operand-residual-value op)
+ (visit-operand op counter 'value 10 10))))
+ (cond
+ ((and (lexical-ref? y)
+ (= (lexical-refcount (lexical-ref-gensym x)) 1))
+ ;; X is a simple alias for Y. Recurse, regardless of
+ ;; the number of aliases we were expecting.
+ (find-definition y n-aliases))
+ ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
+ ;; We found a definition that is aliased the right
+ ;; number of times. We still recurse in case it is a
+ ;; lexical.
+ (values (find-definition y 1)
+ op))
+ (else
+ ;; We can't account for our aliases.
+ (values #f #f))))))
+ (else
+ ;; A formal parameter. Can't say anything about that.
+ (values #f #f))))
+ ((= n-aliases 1)
+ ;; Not a lexical: success, but only if we are looking for an
+ ;; unaliased value.
+ (values x #f))
+ (else (values #f #f))))
+
+ (let ((tag (for-value tag))
+ (body (for-tail body)))
+ (cond
+ ((find-definition tag 1)
+ (lambda (val op)
+ (make-prompt-tag? val))
+ => (lambda (val op)
+ ;; There is no way that an <abort> could know the tag
+ ;; for this <prompt>, so we can elide the <prompt>
+ ;; entirely.
+ (unrecord-operand-uses op 1)
+ body))
+ ((find-definition tag 2)
+ (lambda (val op)
+ (and (make-prompt-tag? val)
+ (abort? body)
+ (tree-il=? (abort-tag body) tag)))
+ => (lambda (val op)
+ ;; (let ((t (make-prompt-tag)))
+ ;; (call-with-prompt t
+ ;; (lambda () (abort-to-prompt t val ...))
+ ;; (lambda (k arg ...) e ...)))
+ ;; => (let-values (((k arg ...) (values values val ...)))
+ ;; e ...)
+ (unrecord-operand-uses op 2)
+ (for-tail
+ (make-let-values
+ src
+ (make-application #f (make-primitive-ref #f 'apply)
+ `(,(make-primitive-ref #f 'values)
+ ,(make-primitive-ref #f 'values)
+ ,@(abort-args body)
+ ,(abort-tail body)))
+ (for-value handler)))))
+ (else
+ (make-prompt src tag body (for-value handler))))))
(($ <abort> src tag args tail)
(make-abort src (for-value tag) (map for-value args)
(for-value tail))))))
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index de5359f..76f16fb 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -185,6 +185,7 @@
(lambda ()
(let ((p ((@ (system base compile) compile) exp
#:env *dispatch-module*
+ #:from 'scheme
#:opts '(#:partial-eval? #f #:cse? #f))))
(apply p vals)))))
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index d01d318..523635f 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -286,4 +286,10 @@
(apply (primitive car) (toplevel x))
(if (apply (primitive car) (toplevel x))
(const one)
- (const two)))))
+ (const two))))
+
+ (pass-if-cse
+ (begin (cons 1 2 3) 4)
+ (begin
+ (apply (primitive cons) (const 1) (const 2) (const 3))
+ (const 4))))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index aefb2e0..7fae423 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -959,19 +959,24 @@
resolve-primitives
;; `while' without `break' or `continue' has no prompts and gets its
;; condition folded. Unfortunately the outer `lp' does not yet get
- ;; elided.
+ ;; elided, and the continuation tag stays around. (The continue tag
+ ;; stays around because although it is not referenced, recursively
+ ;; visiting the loop in the continue handler manages to visit the tag
+ ;; twice before aborting. The abort doesn't unroll the recursive
+ ;; reference.)
(while #t #t)
- (letrec (lp) (_)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (letrec (loop) (_)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (apply (lexical loop _))))))
- (apply (lexical loop _)))))))
- (apply (lexical lp _))))
+ (let (_) (_) ((apply (primitive make-prompt-tag) . _))
+ (letrec (lp) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (letrec (loop) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (apply (lexical loop _))))))
+ (apply (lexical loop _)))))))
+ (apply (lexical lp _)))))
(pass-if-peval
resolve-primitives
@@ -1055,4 +1060,19 @@
(apply (toplevel baz) (toplevel x))
(apply (lexical failure _)))))
(apply (lexical failure _)))
- (apply (lexical failure _))))))
+ (apply (lexical failure _)))))
+
+ (pass-if-peval resolve-primitives
+ (apply (lambda (x y) (cons x y)) '(1 2))
+ (apply (primitive cons) (const 1) (const 2)))
+
+ (pass-if-peval resolve-primitives
+ (apply (lambda (x y) (cons x y)) (list 1 2))
+ (apply (primitive cons) (const 1) (const 2)))
+
+ (pass-if-peval resolve-primitives
+ (let ((t (make-prompt-tag)))
+ (call-with-prompt t
+ (lambda () (abort-to-prompt t 1 2 3))
+ (lambda (k x y z) (list x y z))))
+ (apply (primitive 'list) (const 1) (const 2) (const 3))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-197-gb8a5606,
Andy Wingo <=