~ chicken-core (chicken-5) e84482088fe82289866967ca66ce4c0aaf48ff67
commit e84482088fe82289866967ca66ce4c0aaf48ff67
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Wed Jun 16 08:35:33 2021 +0200
Commit: megane <meganeka@gmail.com>
CommitDate: Thu Jun 17 15:19:21 2021 +0300
Refactor replacing of rest args to make it reusable
This moves the replacing of rest args with corresponding list ops into
a procedure in support.scm
Signed-off-by: megane <meganeka@gmail.com>
Note: This also removes an unused (test here 'customizable) test:
< sjamaan> Oh, right. That branch was totally bogus
< sjamaan> Because customizable refers to the call site, not the procedure
diff --git a/core.scm b/core.scm
index c484071c..630bfd04 100644
--- a/core.scm
+++ b/core.scm
@@ -2649,37 +2649,12 @@
;; This can be improved, as it can actually introduce
;; many more cdr calls than necessary.
(cond ((eq? class '##core#rest-cdr)
- (let lp ((cdr-calls (add1 (second params)))
- (var rest-var))
- (if (zero? cdr-calls)
- (transform var here closure)
- (lp (sub1 cdr-calls)
- (make-node '##core#inline (list "C_i_cdr") (list var))))))
-
- ;; If customizable, the list is consed up at the
- ;; call site and there is no argvector. So convert
- ;; back to list-ref/list-tail calls.
- ;;
- ;; Alternatively, if n isn't val, this node was
- ;; processed and the variable got replaced by a
- ;; closure access.
- ((or (test here 'customizable)
- (not (eq? val n)))
- (case class
- ((##core#rest-car)
- (transform (make-node '##core#inline
- (list "C_i_list_ref")
- (list rest-var (qnode (second params)))) here closure))
- ((##core#rest-null?)
- (transform (make-node '##core#inline
- (list "C_i_greater_or_equalp")
- (list (qnode (second params))
- (make-node '##core#inline (list "C_i_length") (list rest-var)))) here closure))
- ((##core#rest-length)
- (transform (make-node '##core#inline
- (list "C_i_length")
- (list rest-var (qnode (second params)))) here closure))
- (else (bomb "Unknown rest op node class while converting to closure. This shouldn't happen!" class))))
+ (transform (replace-rest-op-with-list-ops class rest-var params) here closure))
+
+ ;; If n isn't val, this node was processed and the
+ ;; variable got replaced by a closure access.
+ ((not (eq? val n))
+ (transform (replace-rest-op-with-list-ops class rest-var params) here closure))
(else val)) ) )
diff --git a/support.scm b/support.scm
index b93fb8ef..b56b7d00 100644
--- a/support.scm
+++ b/support.scm
@@ -34,7 +34,7 @@
debugging-chicken with-debugging-output quit-compiling
emit-syntax-trace-info check-signature build-lambda-list
c-ify-string valid-c-identifier? read-expressions
- bytes->words words->bytes
+ bytes->words words->bytes replace-rest-op-with-list-ops
check-and-open-input-file close-checked-input-file fold-inner
constant? collapsable-literal? immediate? basic-literal?
canonicalize-begin-body string->expr llist-length llist-match?
@@ -779,6 +779,30 @@
(walk node) )
+(define (replace-rest-op-with-list-ops class rest-var-node params)
+ (case class
+ ((##core#rest-car)
+ (make-node '##core#inline
+ (list "C_i_list_ref")
+ (list rest-var-node (qnode (second params)))))
+ ((##core#rest-cdr)
+ (let lp ((cdr-calls (add1 (second params)))
+ (var rest-var-node))
+ (if (zero? cdr-calls)
+ var
+ (lp (sub1 cdr-calls)
+ (make-node '##core#inline (list "C_i_cdr") (list var))))))
+ ((##core#rest-null?)
+ (make-node '##core#inline
+ (list "C_i_greater_or_equalp")
+ (list (qnode (second params))
+ (make-node '##core#inline (list "C_i_length") (list rest-var-node)))))
+ ((##core#rest-length)
+ (make-node '##core#inline
+ (list "C_i_length")
+ (list rest-var-node (qnode (second params)))))
+ (else (bomb "Unknown rest op node class while undoing rest op for explicitly consed rest arg. This shouldn't happen!" class))))
+
;; Maybe move to scrutinizer. It's generic enough to keep it here though
(define (tree-copy t)
(let rec ([t t])
Trap