mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +02:00
Code Activity

don't propagate pure primcalls that might not type-check

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2011-09-27 23:20:49 +02:00
parent b5ae223d12
commit fc283c92cb
2 changed files with 19 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

17
module/language/tree-il/optimize.scm
View file

@ -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.

5
test-suite/tests/tree-il.test
View file

@ -1085,8 +1085,9 @@
(let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
(apply (toplevel frob!))
(apply (toplevel display) (const chbouib))))
(apply (primitive +) (lexical x _) (lexical x _)
(apply (primitive *) (lexical x _) (const 2)))))
(let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
(apply (primitive +)
(lexical x _) (lexical x _) (lexical y _)))))
(pass-if-peval
;; Non-constant arguments not propagated to lambdas.