diff options
author | Andy Wingo <wingo@pobox.com> | 2011-09-27 23:20:49 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-09-28 00:13:56 +0200 |
commit | fc283c92cbdb31942f033541b52376fd1bade3f2 (patch) | |
tree | ae63992fb5af9063328d3959160660b1fbc30c48 /module/language/tree-il/optimize.scm | |
parent | b5ae223d129b427e2b5695c82c45f16995f36236 (diff) | |
download | guile-fc283c92cbdb31942f033541b52376fd1bade3f2.tar.gz |
don't propagate pure primcalls that might not type-check
* module/language/tree-il/optimize.scm (types-check?): New helper, to
determine if a primcall will apply without throwing an exception.
(peval): constant-expression? returns #f for expressions that don't
types-check?. Effect-free primitives that type-check are void.
Diffstat (limited to 'module/language/tree-il/optimize.scm')
-rw-r--r-- | module/language/tree-il/optimize.scm | 17 |
1 files changed, 16 insertions, 1 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index e9317efd1..369c2e44f 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -296,6 +296,16 @@ references to the new symbols." (transfer! current c effort-limit size-limit) c)) +(define (types-check? primitive-name args) + (case primitive-name + ((values) #t) + ((not pair? null? list? symbol? vector? struct?) + (= (length args) 1)) + ((eq? eqv? equal?) + (= (length args) 2)) + ;; FIXME: add more cases? + (else #f))) + (define* (peval exp #:optional (cenv (current-module)) (env vlist-null) #:key (operator-size-limit 40) @@ -472,6 +482,7 @@ it does not handle <fix> and <let-values>, it should be called before (($ <application> _ ($ <primitive-ref> _ name) args) (and (effect-free-primitive? name) (not (constructor-primitive? name)) + (types-check? name args) (every loop args))) (($ <application> _ ($ <lambda> _ _ body) args) (and (loop body) (every loop args))) @@ -818,7 +829,11 @@ it does not handle <fix> and <let-values>, it should be called before (make-values src (map (cut make-const src <>) values)))) (make-application src proc args))) - (make-application src proc args)))) + (cond + ((and (eq? ctx 'effect) (types-check? name args)) + (make-void #f)) + (else + (make-application src proc args)))))) (($ <lambda> _ _ ($ <lambda-case> _ req opt #f #f inits gensyms body #f)) ;; Simple case: no rest, no keyword arguments. |