From ed34e4857f319f3654f37680ebd4c358c494f286 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Wed, 16 Jun 2021 08:35:33 +0200 Subject: [PATCH 2/3] 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 --- core.scm | 37 ++++++------------------------------- support.scm | 26 +++++++++++++++++++++++++- 2 files changed, 31 insertions(+), 32 deletions(-) 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]) -- 2.20.1