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

inline calls to (memv foo CONSTANT-LIST)

Browse source 
* module/language/tree-il/primitives.scm
  (*interesting-primitive-names*): Recognize memv and memq as well.

* module/language/tree-il/inline.scm (inline!): Inline calls to memq and
  memv where the list is a constant.
This commit is contained in:
Andy Wingo 2009-12-11 12:20:55 +01:00
parent b6d93b1182
commit 349d5c4428
2 changed files with 45 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

64
module/language/tree-il/inline.scm
View file

@ -50,27 +50,51 @@
(or (inline1 x) x))
(lp alternate)))))))
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
;; => (let-values (((a b . c) foo)) bar)
;;
;; Note that this is a singly-binding form of let-values. Also
;; note that Scheme's let-values expands into call-with-values,
;; then here we reduce it to tree-il's let-values.
((<primitive-ref> name)
(and (eq? name '@call-with-values)
(pmatch args
((,producer ,consumer)
(guard (lambda? consumer)
(lambda-case? (lambda-body consumer))
(not (lambda-case-opt (lambda-body consumer)))
(not (lambda-case-kw (lambda-body consumer)))
(not (lambda-case-alternate (lambda-body consumer))))
(make-let-values
src
(let ((x (make-application src producer '())))
(or (inline1 x) x))
(lambda-body consumer)))
(else #f))))
(case name
((@call-with-values)
(pmatch args
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
;; => (let-values (((a b . c) foo)) bar)
;;
;; Note that this is a singly-binding form of let-values.
;; Also note that Scheme's let-values expands into
;; call-with-values, then here we reduce it to tree-il's
;; let-values.
((,producer ,consumer)
(guard (lambda? consumer)
(lambda-case? (lambda-body consumer))
(not (lambda-case-opt (lambda-body consumer)))
(not (lambda-case-kw (lambda-body consumer)))
(not (lambda-case-alternate (lambda-body consumer))))
(make-let-values
src
(let ((x (make-application src producer '())))
(or (inline1 x) x))
(lambda-body consumer)))
(else #f)))
((memq memv)
(pmatch args
((,k ,l) (guard (const? l) (list? (const-exp l)))
(let lp ((elts (const-exp l)))
(if (null? elts)
(make-const #f #f)
(make-conditional
src
(make-application
#f
(make-primitive-ref #f (case name
((memq) 'eq?)
((memv) 'eqv?)
(else (error "what"))))
(list k (make-const #f (car elts))))
(make-const #f #t)
(lp (cdr elts))))))
(else #f)))
(else #f)))
(else #f)))

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

@ -34,6 +34,7 @@
call/cc
values
eq? eqv? equal?
memq memv
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor