summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-12-11 12:20:55 +0100
committerAndy Wingo <wingo@pobox.com>2009-12-11 12:20:55 +0100
commit349d5c442834ee467fd2dbf4caed778310f96932 (patch)
tree6e6c54aaaac7982cedce84fad7f30fdcadf4574d
parentb6d93b118271409c6c1b3d163a3b3cf329c77b17 (diff)
downloadguile-349d5c442834ee467fd2dbf4caed778310f96932.tar.gz
inline calls to (memv foo CONSTANT-LIST)
* 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.
-rw-r--r--module/language/tree-il/inline.scm64
-rw-r--r--module/language/tree-il/primitives.scm1
2 files changed, 45 insertions, 20 deletions
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
index 841429fbb..517ff1bd5 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -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)))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 07d4a5561..a8767aef8 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -34,6 +34,7 @@
call/cc
values
eq? eqv? equal?
+ memq memv
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor