summaryrefslogtreecommitdiff
path: root/module/language/tree-il/optimize.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-09-27 23:20:49 +0200
committerAndy Wingo <wingo@pobox.com>2011-09-28 00:13:56 +0200
commitfc283c92cbdb31942f033541b52376fd1bade3f2 (patch)
treeae63992fb5af9063328d3959160660b1fbc30c48 /module/language/tree-il/optimize.scm
parentb5ae223d129b427e2b5695c82c45f16995f36236 (diff)
downloadguile-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.scm17
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.