summaryrefslogtreecommitdiff
path: root/module/language/tree-il/inline.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/tree-il/inline.scm')
-rw-r--r--module/language/tree-il/inline.scm120
1 files changed, 53 insertions, 67 deletions
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
index f23fd6f5d..16af52a18 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -47,44 +47,36 @@
(else x)))
(else x)))
- ((<call> 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-call
- #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)))
-
+ ((<primcall> src name args)
+ (pmatch (cons name args)
+ ((,member ,k ,l) (guard (and (memq member '(memq memv))
+ (const? k)
+ (list? (const-exp l))))
+ (cond
+ ((null? (const-exp l))
+ (make-const #f #f))
+ ((const? k)
+ (make-const #f (->bool ((case member
+ ((memq) memq)
+ ((memv) memv)
+ (else (error "what" member)))
+ (const-exp k) (const-exp l)))))
+ (else
+ (let lp ((elts (const-exp l)))
+ (let ((test (make-primcall
+ #f
+ (case member
+ ((memq) 'eq?)
+ ((memv) 'eqv?)
+ (else (error "what" member)))
+ (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)))
((<lambda> meta body)
@@ -114,34 +106,29 @@
(or (inline1 x) x))
(lp alternate)))))))
- ((<primitive-ref> name)
- (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-call src producer '())))
- (or (inline1 x) x))
- (lambda-body consumer)))
- (else #f)))
-
- (else #f)))
-
(else #f)))
+ ((<primcall> src name args)
+ (pmatch (cons name 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.
+ ((@call-with-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-call src producer '())))
+ (or (inline1 x) x))
+ (lambda-body consumer)))
+ (else #f)))
+
((<conditional> test consequent alternate)
(let ((btest (boolean-value test)))
(or (record-case btest
@@ -178,10 +165,9 @@
(and (not opt) (not kw) rest (not alternate)
(record-case body
- ((<call> proc args)
+ ((<primcall> name args)
;; (lambda args (apply (lambda ...) args)) => (lambda ...)
- (and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@apply)
+ (and (eq? name '@apply)
(pair? args)
(lambda? (car args))
(args-compatible? (cdr args) gensyms)