mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

fix memq/memv inlining

Browse source 
* module/language/tree-il/inline.scm (boolean-value): Add a case for
  applications of primitives, and move the memq/memv->bool code here.
  (inline!): We were inlining (memq 'a '(a b c)) => #t, and not the list
  tail, which was an embarrassing bug.  Fixed by moving this code to the
  boolean-value function.  Thanks to Mark Harig for the report.
This commit is contained in:
Andy Wingo 2011-02-07 21:58:51 +01:00
parent c415fe081e
commit a75ea65896
1 changed files with 41 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,6 @@
;;; a simple inliner
;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -47,6 +47,46 @@
(else x)))
(else x)))
((<application> src proc args)
(record-case proc
;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
((<primitive-ref> name)
(case name
((memq memv)
(pmatch args
((,k ,l) (guard (const? l) (list? (const-exp l)))
(cond
((null? (const-exp l))
(make-const #f #f))
((const? k)
(make-const #f (->bool ((case name
((memq) memq)
((memv) memv)
(else (error "unexpected member func" name)))
(const-exp k) (const-exp l)))))
(else
(let lp ((elts (const-exp l)))
(let ((test (make-application
#f
(make-primitive-ref #f (case name
((memq) 'eq?)
((memv) 'eqv?)
(else (error "what"))))
(list k (make-const #f (car elts))))))
(if (null? (cdr elts))
test
(make-conditional
src
test
(make-const #f #t)
(lp (cdr elts)))))))))
(else x)))
(else x)))
(else x)))
((<lambda> meta body)
(make-const src #t))
@ -98,29 +138,6 @@
(lambda-body consumer)))
(else #f)))
((memq memv)
(pmatch args
((,k ,l) (guard (const? l) (list? (const-exp l)))
(if (null? (const-exp l))
(make-const #f #f)
(let lp ((elts (const-exp l)))
(let ((test (make-application
#f
(make-primitive-ref #f (case name
((memq) 'eq?)
((memv) 'eqv?)
(else (error "what"))))
(list k (make-const #f (car elts))))))
(if (null? (cdr elts))
test
(make-conditional
src
test
(make-const #f #t)
(lp (cdr elts))))))))
(else #f)))
(else #f)))
(else #f)))