Ticket #1623: rest-args.patch

batch-driver.scm

@@ -146 +146 @@
                        ((potential-values)
                         (set! pvals (cdar es)))
                        ((replacable home contains contained-in use-expr closure-size rest-parameter
-                                    captured-variables explicit-rest)
+                                    captured-variables explicit-rest rest-cdr rest-null?)
                         (printf "\t~a=~s" (caar es) (cdar es)) )
                        ((references)
                         (set! refs (cdar es)) )

c-backend.scm

@@ -181 +181 @@
              (expr (car subs) i)
              (gen ")[" (+ (first params) 1) #\]) )
 
+            ((##core#rest-car)
+             (let* ((n (lambda-literal-argument-count ll))
+                    (idx (+ (second params) n)))
+               (gen "C_get_rest_arg(c," idx ",av)")))
+
+            ((##core#rest-null?)
+             (let* ((n (lambda-literal-argument-count ll))
+                    (idx (+ (second params) n)))
+               (gen "C_rest_nullp(c, " idx ")")))
+
             ((##core#unbox) 
              (gen "((C_word*)")
              (expr (car subs) i)
@@ -632 +642 @@
                 (customizable (lambda-literal-customizable ll))
                 (empty-closure (and customizable (zero? (lambda-literal-closure-size ll))))
                 (varlist (intersperse (make-variable-list (if empty-closure (sub1 n) n) "t") #\,))
-                (rest (lambda-literal-rest-argument ll))
-                (rest-mode (lambda-literal-rest-argument-mode ll))
                 (direct (lambda-literal-direct ll))
                 (allocated (lambda-literal-allocated ll)) )
            (gen #t)
@@ -679 +687 @@
            (let* ([id (car p)]
                   [ll (cdr p)]
                   [argc (lambda-literal-argument-count ll)]
-                  [rest (lambda-literal-rest-argument ll)]
-                  [rest-mode (lambda-literal-rest-argument-mode ll)]
                   [customizable (lambda-literal-customizable ll)]
                   [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] )
              (when empty-closure (set! argc (sub1 argc)))
@@ -923 +929 @@
                                 (apply gen arglist)
                                 (gen ");}"))
                                (else
-                                (gen #t "C_save_and_reclaim((void *)" id #\, n ",av);}")))
+                                (gen #t "C_save_and_reclaim((void *)" id ",c,av);}")))
                          (when (> demand 0)
                            (gen #t "a=C_alloc(" demand ");")))))
                  (else (gen #\})))

chicken.h

@@ -1244 +1244 @@
 #define C_offset_pointer(x, y)          (C_pointer_address(x) + (y))
 #define C_do_apply(c, av)               ((C_proc)(void *)C_block_item((av)[0], 0))((c), (av))
 #define C_kontinue(k, r)                do { C_word avk[ 2 ]; avk[ 0 ] = (k); avk[ 1 ] = (r); ((C_proc)(void *)C_block_item((k),0))(2, avk); } while(0)
+#define C_get_rest_arg(c, n, av)        ((n) >= (c) ? ((n) == (c) ? C_i_car(C_SCHEME_END_OF_LIST) : C_i_cdr(C_SCHEME_END_OF_LIST)) : (av)[(n)])
+#define C_rest_nullp(c, n)              (C_mk_bool((n) >= (c)))
 #define C_fetch_byte(x, p)              (((unsigned C_byte *)C_data_pointer(x))[ p ])
 #define C_poke_integer(x, i, n)         (C_set_block_item(x, C_unfix(i), C_num_to_int(n)), C_SCHEME_UNDEFINED)
 #define C_pointer_to_block(p, x)        (C_set_block_item(p, 0, (C_word)C_data_pointer(x)), C_SCHEME_UNDEFINED)
@@ -1629 +1631 @@
 #define C_i_true2(dummy1, dummy2)      ((dummy1), (dummy2), C_SCHEME_TRUE)
 #define C_i_true3(dummy1, dummy2, dummy3)  ((dummy1), (dummy2), (dummy3), C_SCHEME_TRUE)
 
-
 /* debug client interface */
 
 typedef struct C_DEBUG_INFO {

core.scm

@@ -178 +178 @@
 ; [##core#call {<safe-flag> [<debug-info>]} <exp-f> <exp>...]
 ; [##core#callunit {<unitname>} <exp>...]
 ; [##core#switch {<count>} <exp> <const1> <body1> ... <defaultbody>]
+; [##core#rest-car {restvar depth [<debug-info>]}]
+; [##core#rest-cdr {restvar depth [<debug-info>]}]
+; [##core#rest-null? {restvar depth [<debug-info>]} <restvar>]
 ; [##core#cond <exp> <exp> <exp>]
 ; [##core#provide <id>]
 ; [##core#recurse {<tail-flag>} <exp1> ...]
@@ -257 +260 @@
 ;   extended-binding -> <boolean>            If true: variable names an extended binding
 ;   unused -> <boolean>                      If true: variable is a formal parameter that is never used
 ;   rest-parameter -> #f | 'list             If true: variable holds rest-argument list
+;   rest-cdr -> (rvar . n)                   Variable references the cdr of rest list rvar after n cdrs (0 = rest list itself)
+;   rest-null? -> (rvar . n)                 Variable checks if the cdr of rest list rvar after n cdrs is empty (0 = rest list itself)
 ;   constant -> <boolean>                    If true: variable has fixed value
 ;   hidden-refs -> <boolean>                 If true: procedure that refers to hidden global variables
 ;   inline-transient -> <boolean>            If true: was introduced during inlining
@@ -2096 +2101 @@
         (case class
           ((quote ##core#undefined ##core#provide ##core#proc) #f)
 
-          ((##core#variable)
+          ;; Uneliminated rest-cdr calls need to hang on to rest var
+          ((##core#variable ##core#rest-cdr)
            (let ((var (first params)))
              (ref var n)
              (unless (memq var localenv)
@@ -2160 +2166 @@
                    (db-put! db var 'unknown #t) )
                  vars)
                 (when rest
-                  (db-put! db rest 'rest-parameter 'list) )
+                  (db-put! db rest 'rest-parameter 'list)
+                  (db-put! db rest 'rest-cdr (cons rest 0)))
                 (when (simple-lambda-node? n) (db-put! db id 'simple #t))
                 (let ([tl toplevel-scope])
                   (unless toplevel-lambda-id (set! toplevel-lambda-id id))
@@ -2204 +2211 @@
       (for-each (lambda (x) (walk x env lenv fenv here)) xs) )
 
     (define (assign var val env here)
+      ;; Propagate rest-cdr and rest-null? onto aliased variables
+      (and-let* (((eq? '##core#variable (node-class val)))
+                 (v (db-get db (first (node-parameters val)) 'rest-cdr)))
+        (db-put! db var 'rest-cdr v) )
+
+      (and-let* (((eq? '##core#variable (node-class val)))
+                 (v (db-get db (first (node-parameters val)) 'rest-null?)))
+        (db-put! db var 'rest-null? v) )
+
       (cond ((eq? '##core#undefined (node-class val))
              (db-put! db var 'undefined #t) )
             ((and (eq? '##core#variable (node-class val)) ; assignment to itself
                   (eq? var (first (node-parameters val))) ) )
+
+            ;; Propagate info from ##core#rest-{cdr,null?} nodes to var
+            ((eq? '##core#rest-cdr (node-class val))
+             (let ((restvar (car (node-parameters val)))
+                   (depth (cadr (node-parameters val))))
+               (db-put! db var 'rest-cdr (cons restvar (add1 depth))) ) )
+
+            ((eq? '##core#rest-null? (node-class val))
+             (let ((restvar (car (node-parameters val)))
+                   (depth (cadr (node-parameters val))))
+               (db-put! db var 'rest-null? (cons restvar depth)) ) )
+
+            ;; (##core#cond (null? r) '() (cdr r)) => result is tagged as a rest-cdr var
+            ((and-let* (((eq? '##core#cond (node-class val)))
+                        (subs (node-subexpressions val))
+                        ((eq? '##core#variable (node-class (car subs))))
+                        ((db-get db (first (node-parameters (car subs))) 'rest-null?))
+                        (node-when-null (cadr subs))
+                        ((eq? 'quote (node-class node-when-null)))
+                        ((eq? '() (first (node-parameters node-when-null))))
+                        (rest-cdr-node (caddr subs))
+                        ((eq? '##core#rest-cdr (node-class rest-cdr-node))))
+               rest-cdr-node)
+             => (lambda (rest-cdr-node)
+                 (let ((restvar (car (node-parameters rest-cdr-node)))
+                       (depth (cadr (node-parameters rest-cdr-node))))
+                   (db-put! db var 'rest-cdr (cons restvar (add1 depth))) )) )
+
             ((or (memq var env)
                  (variable-mark var '##compiler#constant)
                  (not (variable-visible? var block-compilation)))
@@ -2257 +2301 @@
              [assigned-locally #f]
              [undefined #f]
              [global #f]
-             [rest-parameter #f]
              [nreferences 0]
+             [rest-cdr #f]
              [ncall-sites 0] )
 
          (set! current-analysis-database-size (fx+ current-analysis-database-size 1))
@@ -2282 +2326 @@
               [(global) (set! global #t)]
               [(value) (set! value (cdr prop))]
               [(local-value) (set! local-value (cdr prop))]
-              [(rest-parameter) (set! rest-parameter #t)] ) )
+              [(rest-cdr) (set! rest-cdr (cdr prop))] ) )
           plist)
 
          (set! value (and (not unknown) value))
@@ -2397 +2441 @@
                             (rest
                              (db-put! db (first lparams) 'explicit-rest #t) ) ) ) ) ) ) ) ) )
 
-         ;; Make 'removable, if it has no references and is not assigned to, and if it
-         ;; has either a value that does not cause any side-effects or if it is 'undefined:
+         ;; Make 'removable, if it has no references and is not assigned to, and one of the following:
+         ;; - it has either a value that does not cause any side-effects
+         ;; - it is 'undefined
+         ;; - it holds only a 'rest-cdr reference (strictly speaking, it may bomb but we don't care)
          (when (and (not assigned)
                     (null? references)
                     (or (and value
@@ -2408 +2454 @@
                                        (variable-mark varname '##core#always-bound)
                                        (intrinsic? varname)))
                                  (not (expression-has-side-effects? value db)) ))
-                        undefined) )
+                        undefined
+                        rest-cdr) )
            (quick-put! plist 'removable #t) )
 
          ;; Make 'replacable, if
@@ -2494 +2541 @@
             (params (node-parameters n)) )
         (case (node-class n)
 
-          ((##core#variable)
+          ((##core#variable ##core#rest-cdr)
            (let ((var (first params)))
              (if (memq var lexicals)
                  (list var)
@@ -2590 +2637 @@
                  (make-node '##core#unbox '() (list val))
                  val) ) )
 
+          ((##core#rest-cdr ##core#rest-car ##core#rest-null?)
+           (let* ((rest-var (first params))
+                  (val (ref-var n here closure)))
+             (unless (eq? val n)
+               ;; If it's captured, replacement in optimizer was incorrect
+               (quit-compiling "Saw rest op `~s' for captured variable.  This should not happen!" class) )
+             ;; If rest-cdrs have not all been eliminated, restore
+             ;; them as regular cdr calls on the rest list variable.
+             ;; This can be improved, as it can actually introduce
+             ;; many more cdr calls than necessary.
+             (if (eq? class '##core#rest-cdr)
+                 (let lp ((cdr-calls (add1 (second params)))
+                          (var (varnode rest-var)))
+                   (if (zero? cdr-calls)
+                       (transform var here closure)
+                       (lp (sub1 cdr-calls)
+                           (make-node '##core#inline (list "C_i_cdr") (list var)))))
+                 val) ) )
+
           ((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit
                ##core#inline_ref ##core#inline_update ##core#debug-event
                ##core#switch ##core#cond ##core#direct_call ##core#recurse ##core#return

optimizer.scm

@@ -189 +189 @@
                  entry) )
           n) )
 
+
+    (define (maybe-replace-rest-arg-calls node)
+      ;; Ugh, we need to match on the core inlined string instead of
+      ;; the call to the intrinsic itself, because rewrites will have
+      ;; introduced this after the first iteration.
+      (or (and-let* (((eq? '##core#inline (node-class node)))
+                     (native (->string (car (node-parameters node)))) ;; NOTE: should always be string?
+                     (replacement-op (cond
+                                      ((string=? native "C_i_car") '##core#rest-car)
+                                      ((string=? native "C_i_cdr") '##core#rest-cdr)
+                                      ((string=? native "C_i_nullp") '##core#rest-null?)
+                                      (else #f)))
+                     (arg (first (node-subexpressions node)))
+                     ((eq? '##core#variable (node-class arg)))
+                     (var (first (node-parameters arg)))
+                     ((not (db-get db var 'captured)))
+                     (info (db-get db var 'rest-cdr))
+                     (restvar (car info))
+                     (depth (cdr info))
+                     ((not (test var 'assigned))))
+            ;; callee is intrinsic and accesses rest arg sublist
+            (debugging 'o "known list op on rest arg sublist"
+                       (call-info (node-parameters node) replacement-op) var depth)
+            (touch)
+            (make-node replacement-op
+                       (cons* restvar depth (cdr (node-parameters node)))
+                       (list) ) )
+          node) )
+
     (define (walk n fids gae)
       (if (memq n broken-constant-nodes)
           n
@@ -208 +237 @@
                              fids gae) )
                       (else n1) ) )
 
+               ((##core#inline)
+                (maybe-replace-rest-arg-calls n1))
+
                ((##core#call)
                 (maybe-constant-fold-call
                  n1

support.scm

@@ -650 +650 @@
        (let* ((rlist (if copy? (map gensym vars) vars))
               (body (if copy? 
                         (copy-node-tree-and-rename body vars rlist db cfk)
-                        body) ) )
+                        body) )
+              (rarg-aliases (map (lambda (r) (gensym 'rarg)) rargs)) )
+         (replace-rest-ops-in-known-call! db body rest (last rlist) rarg-aliases)
          (let loop ((vars (take rlist argc))
                     (vals largs))
            (if (null? vars)
                (if rest
-                   (make-node
-                    'let (list (last rlist))
-                    (list (if (null? rargs)
-                              (qnode '())
-                              (make-node
-                               '##core#inline_allocate
-                               (list "C_a_i_list" (* 3 (length rargs))) 
-                               rargs) )
-                          body) )
+                   ;; NOTE: If contraction happens before rest-op
+                   ;; detection, we might needlessly build a list.
+                   (let loop2 ((rarg-values rargs)
+                               (rarg-aliases rarg-aliases))
+                     (if (null? rarg-aliases)
+                         (if (null? (db-get-list db rest 'references))
+                             body
+                             (make-node
+                              'let (list (last rlist))
+                              (list (if (null? rargs)
+                                        (qnode '())
+                                        (make-node
+                                         '##core#inline_allocate
+                                         (list "C_a_i_list" (* 3 (length rargs))) 
+                                         rargs) )
+                                    body) ))
+                         (make-node 'let (list (car rarg-aliases))
+                                    (list (car rarg-values)
+                                          (loop2 (cdr rarg-values) (cdr rarg-aliases))))))
                    body)
                (make-node 'let (list (car vars))
                           (list (car vals)
@@ -718 +730 @@
                            (map (cut walk <> rl) subs))) ) ) )
     (walk node rlist) ) )
 
+;; Replace rest-{car,cdr,null?} with equivalent code which accesses
+;; the rest argument directly.
+(define (replace-rest-ops-in-known-call! db node rest-var rest-alias rest-args)
+  (define (walk n)
+    (let ((subs (node-subexpressions n))
+          (params (node-parameters n))
+          (class (node-class n)) )
+      (case class
+        ((##core#rest-null?)
+         (if (eq? rest-var (first params))
+             (copy-node! (qnode (<= (length rest-args) (second params))) n)
+             n))
+        ((##core#rest-car)
+         (if (eq? rest-var (first params))
+             (let ((depth (second params))
+                   (len (length rest-args)))
+               (if (> len depth)
+                   (copy-node! (varnode (list-ref rest-args depth)) n)
+                   ;; Emit code which will crash at runtime, because
+                   ;; there aren't enough arguments...
+                   (copy-node! (make-node '##core#inline
+                                          (list (if (= len depth) "C_i_car" "C_i_cdr"))
+                                          (list (qnode '())))
+                               n)))
+             n))
+        ((##core#rest-cdr)
+         (cond ((eq? rest-var (first params))
+                (collect! db rest-var 'references n) ; Restore this reference
+                (let lp ((i (add1 (second params)))
+                         (new-node (varnode rest-alias)))
+                  (if (zero? i)
+                      (copy-node! new-node n)
+                      (lp (sub1 i)
+                          (make-node '##core#inline (list "C_i_cdr") (list new-node))))))
+               (else n)))
+        (else (for-each walk subs)) ) ) )
+
+  (walk node)  )
+
 ;; Maybe move to scrutinizer.  It's generic enough to keep it here though
 (define (tree-copy t)
   (let rec ([t t])

tests/syntax-tests.scm

@@ -864 +864 @@
 
 (assert (equal? '(3 4 5 (6 7)) (test-optional&rest 3 4 5 6 7)))
 
+(define (test-optional&rest-cdrs x y #!optional z #!rest r)
+  (list x y z (cdr (cdr r))))
+
+(assert (equal? '(3 4 5 ()) (test-optional&rest-cdrs 3 4 5 6 7)))
+
+;; Ensure that rest conversion is not applied too aggressively.
+;; (only when the consequence is () should it be applied)
+(define (rest-nonnull-optimization . rest)
+  (let ((x (if (null? (cdr rest))
+               '(foo)
+               (cdr rest))))
+    (null? x)))
+
+(assert (not (rest-nonnull-optimization 1)))
+(assert (not (rest-nonnull-optimization 1 2)))
+
+(assert (equal? '(3 4 5 ()) (test-optional&rest-cdrs 3 4 5 6 7)))
+
 (define (test-optional&key x y #!optional z #!key i (j 1))
   (list x y z i: i j: j))