Ticket #1623: rest-args.patch

File rest-args.patch, 16.3 KB (added by sjamaan, 13 months ago)

Patch against e25965

  • batch-driver.scm

    diff --git a/batch-driver.scm b/batch-driver.scm
    index 82ed562e..f4393a49 100644
    a b  
    146146                       ((potential-values)
    147147                        (set! pvals (cdar es)))
    148148                       ((replacable home contains contained-in use-expr closure-size rest-parameter
    149                                     captured-variables explicit-rest)
     149                                    captured-variables explicit-rest rest-cdr rest-null?)
    150150                        (printf "\t~a=~s" (caar es) (cdar es)) )
    151151                       ((references)
    152152                        (set! refs (cdar es)) )
  • c-backend.scm

    diff --git a/c-backend.scm b/c-backend.scm
    index 10134fbc..c3d3b1f0 100644
    a b  
    181181             (expr (car subs) i)
    182182             (gen ")[" (+ (first params) 1) #\]) )
    183183
     184            ((##core#rest-car)
     185             (let* ((n (lambda-literal-argument-count ll))
     186                    (idx (+ (second params) n)))
     187               (gen "C_get_rest_arg(c," idx ",av)")))
     188
     189            ((##core#rest-null?)
     190             (let* ((n (lambda-literal-argument-count ll))
     191                    (idx (+ (second params) n)))
     192               (gen "C_rest_nullp(c, " idx ")")))
     193
    184194            ((##core#unbox)
    185195             (gen "((C_word*)")
    186196             (expr (car subs) i)
     
    632642                (customizable (lambda-literal-customizable ll))
    633643                (empty-closure (and customizable (zero? (lambda-literal-closure-size ll))))
    634644                (varlist (intersperse (make-variable-list (if empty-closure (sub1 n) n) "t") #\,))
    635                 (rest (lambda-literal-rest-argument ll))
    636                 (rest-mode (lambda-literal-rest-argument-mode ll))
    637645                (direct (lambda-literal-direct ll))
    638646                (allocated (lambda-literal-allocated ll)) )
    639647           (gen #t)
     
    679687           (let* ([id (car p)]
    680688                  [ll (cdr p)]
    681689                  [argc (lambda-literal-argument-count ll)]
    682                   [rest (lambda-literal-rest-argument ll)]
    683                   [rest-mode (lambda-literal-rest-argument-mode ll)]
    684690                  [customizable (lambda-literal-customizable ll)]
    685691                  [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] )
    686692             (when empty-closure (set! argc (sub1 argc)))
     
    923929                                (apply gen arglist)
    924930                                (gen ");}"))
    925931                               (else
    926                                 (gen #t "C_save_and_reclaim((void *)" id #\, n ",av);}")))
     932                                (gen #t "C_save_and_reclaim((void *)" id ",c,av);}")))
    927933                         (when (> demand 0)
    928934                           (gen #t "a=C_alloc(" demand ");")))))
    929935                 (else (gen #\})))
  • chicken.h

    diff --git a/chicken.h b/chicken.h
    index dbf6f17b..f6a46ed5 100644
    a b typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; 
    12441244#define C_offset_pointer(x, y)          (C_pointer_address(x) + (y))
    12451245#define C_do_apply(c, av)               ((C_proc)(void *)C_block_item((av)[0], 0))((c), (av))
    12461246#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)
     1247#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)])
     1248#define C_rest_nullp(c, n)              (C_mk_bool((n) >= (c)))
    12471249#define C_fetch_byte(x, p)              (((unsigned C_byte *)C_data_pointer(x))[ p ])
    12481250#define C_poke_integer(x, i, n)         (C_set_block_item(x, C_unfix(i), C_num_to_int(n)), C_SCHEME_UNDEFINED)
    12491251#define C_pointer_to_block(p, x)        (C_set_block_item(p, 0, (C_word)C_data_pointer(x)), C_SCHEME_UNDEFINED)
    typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; 
    16291631#define C_i_true2(dummy1, dummy2)      ((dummy1), (dummy2), C_SCHEME_TRUE)
    16301632#define C_i_true3(dummy1, dummy2, dummy3)  ((dummy1), (dummy2), (dummy3), C_SCHEME_TRUE)
    16311633
    1632 
    16331634/* debug client interface */
    16341635
    16351636typedef struct C_DEBUG_INFO {
  • core.scm

    diff --git a/core.scm b/core.scm
    index 9f39bb30..f9768954 100644
    a b  
    178178; [##core#call {<safe-flag> [<debug-info>]} <exp-f> <exp>...]
    179179; [##core#callunit {<unitname>} <exp>...]
    180180; [##core#switch {<count>} <exp> <const1> <body1> ... <defaultbody>]
     181; [##core#rest-car {restvar depth [<debug-info>]}]
     182; [##core#rest-cdr {restvar depth [<debug-info>]}]
     183; [##core#rest-null? {restvar depth [<debug-info>]} <restvar>]
    181184; [##core#cond <exp> <exp> <exp>]
    182185; [##core#provide <id>]
    183186; [##core#recurse {<tail-flag>} <exp1> ...]
     
    257260;   extended-binding -> <boolean>            If true: variable names an extended binding
    258261;   unused -> <boolean>                      If true: variable is a formal parameter that is never used
    259262;   rest-parameter -> #f | 'list             If true: variable holds rest-argument list
     263;   rest-cdr -> (rvar . n)                   Variable references the cdr of rest list rvar after n cdrs (0 = rest list itself)
     264;   rest-null? -> (rvar . n)                 Variable checks if the cdr of rest list rvar after n cdrs is empty (0 = rest list itself)
    260265;   constant -> <boolean>                    If true: variable has fixed value
    261266;   hidden-refs -> <boolean>                 If true: procedure that refers to hidden global variables
    262267;   inline-transient -> <boolean>            If true: was introduced during inlining
     
    20962101        (case class
    20972102          ((quote ##core#undefined ##core#provide ##core#proc) #f)
    20982103
    2099           ((##core#variable)
     2104          ;; Uneliminated rest-cdr calls need to hang on to rest var
     2105          ((##core#variable ##core#rest-cdr)
    21002106           (let ((var (first params)))
    21012107             (ref var n)
    21022108             (unless (memq var localenv)
     
    21602166                   (db-put! db var 'unknown #t) )
    21612167                 vars)
    21622168                (when rest
    2163                   (db-put! db rest 'rest-parameter 'list) )
     2169                  (db-put! db rest 'rest-parameter 'list)
     2170                  (db-put! db rest 'rest-cdr (cons rest 0)))
    21642171                (when (simple-lambda-node? n) (db-put! db id 'simple #t))
    21652172                (let ([tl toplevel-scope])
    21662173                  (unless toplevel-lambda-id (set! toplevel-lambda-id id))
     
    22042211      (for-each (lambda (x) (walk x env lenv fenv here)) xs) )
    22052212
    22062213    (define (assign var val env here)
     2214      ;; Propagate rest-cdr and rest-null? onto aliased variables
     2215      (and-let* (((eq? '##core#variable (node-class val)))
     2216                 (v (db-get db (first (node-parameters val)) 'rest-cdr)))
     2217        (db-put! db var 'rest-cdr v) )
     2218
     2219      (and-let* (((eq? '##core#variable (node-class val)))
     2220                 (v (db-get db (first (node-parameters val)) 'rest-null?)))
     2221        (db-put! db var 'rest-null? v) )
     2222
    22072223      (cond ((eq? '##core#undefined (node-class val))
    22082224             (db-put! db var 'undefined #t) )
    22092225            ((and (eq? '##core#variable (node-class val)) ; assignment to itself
    22102226                  (eq? var (first (node-parameters val))) ) )
     2227
     2228            ;; Propagate info from ##core#rest-{cdr,null?} nodes to var
     2229            ((eq? '##core#rest-cdr (node-class val))
     2230             (let ((restvar (car (node-parameters val)))
     2231                   (depth (cadr (node-parameters val))))
     2232               (db-put! db var 'rest-cdr (cons restvar (add1 depth))) ) )
     2233
     2234            ((eq? '##core#rest-null? (node-class val))
     2235             (let ((restvar (car (node-parameters val)))
     2236                   (depth (cadr (node-parameters val))))
     2237               (db-put! db var 'rest-null? (cons restvar depth)) ) )
     2238
     2239            ;; (##core#cond (null? r) '() (cdr r)) => result is tagged as a rest-cdr var
     2240            ((and-let* (((eq? '##core#cond (node-class val)))
     2241                        (subs (node-subexpressions val))
     2242                        ((eq? '##core#variable (node-class (car subs))))
     2243                        ((db-get db (first (node-parameters (car subs))) 'rest-null?))
     2244                        (node-when-null (cadr subs))
     2245                        ((eq? 'quote (node-class node-when-null)))
     2246                        ((eq? '() (first (node-parameters node-when-null))))
     2247                        (rest-cdr-node (caddr subs))
     2248                        ((eq? '##core#rest-cdr (node-class rest-cdr-node))))
     2249               rest-cdr-node)
     2250             => (lambda (rest-cdr-node)
     2251                 (let ((restvar (car (node-parameters rest-cdr-node)))
     2252                       (depth (cadr (node-parameters rest-cdr-node))))
     2253                   (db-put! db var 'rest-cdr (cons restvar (add1 depth))) )) )
     2254
    22112255            ((or (memq var env)
    22122256                 (variable-mark var '##compiler#constant)
    22132257                 (not (variable-visible? var block-compilation)))
     
    22572301             [assigned-locally #f]
    22582302             [undefined #f]
    22592303             [global #f]
    2260              [rest-parameter #f]
    22612304             [nreferences 0]
     2305             [rest-cdr #f]
    22622306             [ncall-sites 0] )
    22632307
    22642308         (set! current-analysis-database-size (fx+ current-analysis-database-size 1))
     
    22822326              [(global) (set! global #t)]
    22832327              [(value) (set! value (cdr prop))]
    22842328              [(local-value) (set! local-value (cdr prop))]
    2285               [(rest-parameter) (set! rest-parameter #t)] ) )
     2329              [(rest-cdr) (set! rest-cdr (cdr prop))] ) )
    22862330          plist)
    22872331
    22882332         (set! value (and (not unknown) value))
     
    23972441                            (rest
    23982442                             (db-put! db (first lparams) 'explicit-rest #t) ) ) ) ) ) ) ) ) )
    23992443
    2400          ;; Make 'removable, if it has no references and is not assigned to, and if it
    2401          ;; has either a value that does not cause any side-effects or if it is 'undefined:
     2444         ;; Make 'removable, if it has no references and is not assigned to, and one of the following:
     2445         ;; - it has either a value that does not cause any side-effects
     2446         ;; - it is 'undefined
     2447         ;; - it holds only a 'rest-cdr reference (strictly speaking, it may bomb but we don't care)
    24022448         (when (and (not assigned)
    24032449                    (null? references)
    24042450                    (or (and value
     
    24082454                                       (variable-mark varname '##core#always-bound)
    24092455                                       (intrinsic? varname)))
    24102456                                 (not (expression-has-side-effects? value db)) ))
    2411                         undefined) )
     2457                        undefined
     2458                        rest-cdr) )
    24122459           (quick-put! plist 'removable #t) )
    24132460
    24142461         ;; Make 'replacable, if
     
    24942541            (params (node-parameters n)) )
    24952542        (case (node-class n)
    24962543
    2497           ((##core#variable)
     2544          ((##core#variable ##core#rest-cdr)
    24982545           (let ((var (first params)))
    24992546             (if (memq var lexicals)
    25002547                 (list var)
     
    25902637                 (make-node '##core#unbox '() (list val))
    25912638                 val) ) )
    25922639
     2640          ((##core#rest-cdr ##core#rest-car ##core#rest-null?)
     2641           (let* ((rest-var (first params))
     2642                  (val (ref-var n here closure)))
     2643             (unless (eq? val n)
     2644               ;; If it's captured, replacement in optimizer was incorrect
     2645               (quit-compiling "Saw rest op `~s' for captured variable.  This should not happen!" class) )
     2646             ;; If rest-cdrs have not all been eliminated, restore
     2647             ;; them as regular cdr calls on the rest list variable.
     2648             ;; This can be improved, as it can actually introduce
     2649             ;; many more cdr calls than necessary.
     2650             (if (eq? class '##core#rest-cdr)
     2651                 (let lp ((cdr-calls (add1 (second params)))
     2652                          (var (varnode rest-var)))
     2653                   (if (zero? cdr-calls)
     2654                       (transform var here closure)
     2655                       (lp (sub1 cdr-calls)
     2656                           (make-node '##core#inline (list "C_i_cdr") (list var)))))
     2657                 val) ) )
     2658
    25932659          ((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit
    25942660               ##core#inline_ref ##core#inline_update ##core#debug-event
    25952661               ##core#switch ##core#cond ##core#direct_call ##core#recurse ##core#return
  • optimizer.scm

    diff --git a/optimizer.scm b/optimizer.scm
    index fbf60bac..3b390d8e 100644
    a b  
    189189                 entry) )
    190190          n) )
    191191
     192
     193    (define (maybe-replace-rest-arg-calls node)
     194      ;; Ugh, we need to match on the core inlined string instead of
     195      ;; the call to the intrinsic itself, because rewrites will have
     196      ;; introduced this after the first iteration.
     197      (or (and-let* (((eq? '##core#inline (node-class node)))
     198                     (native (->string (car (node-parameters node)))) ;; NOTE: should always be string?
     199                     (replacement-op (cond
     200                                      ((string=? native "C_i_car") '##core#rest-car)
     201                                      ((string=? native "C_i_cdr") '##core#rest-cdr)
     202                                      ((string=? native "C_i_nullp") '##core#rest-null?)
     203                                      (else #f)))
     204                     (arg (first (node-subexpressions node)))
     205                     ((eq? '##core#variable (node-class arg)))
     206                     (var (first (node-parameters arg)))
     207                     ((not (db-get db var 'captured)))
     208                     (info (db-get db var 'rest-cdr))
     209                     (restvar (car info))
     210                     (depth (cdr info))
     211                     ((not (test var 'assigned))))
     212            ;; callee is intrinsic and accesses rest arg sublist
     213            (debugging 'o "known list op on rest arg sublist"
     214                       (call-info (node-parameters node) replacement-op) var depth)
     215            (touch)
     216            (make-node replacement-op
     217                       (cons* restvar depth (cdr (node-parameters node)))
     218                       (list) ) )
     219          node) )
     220
    192221    (define (walk n fids gae)
    193222      (if (memq n broken-constant-nodes)
    194223          n
     
    208237                             fids gae) )
    209238                      (else n1) ) )
    210239
     240               ((##core#inline)
     241                (maybe-replace-rest-arg-calls n1))
     242
    211243               ((##core#call)
    212244                (maybe-constant-fold-call
    213245                 n1
  • support.scm

    diff --git a/support.scm b/support.scm
    index 729d44aa..64882012 100644
    a b  
    650650       (let* ((rlist (if copy? (map gensym vars) vars))
    651651              (body (if copy?
    652652                        (copy-node-tree-and-rename body vars rlist db cfk)
    653                         body) ) )
     653                        body) )
     654              (rarg-aliases (map (lambda (r) (gensym 'rarg)) rargs)) )
     655         (replace-rest-ops-in-known-call! db body rest (last rlist) rarg-aliases)
    654656         (let loop ((vars (take rlist argc))
    655657                    (vals largs))
    656658           (if (null? vars)
    657659               (if rest
    658                    (make-node
    659                     'let (list (last rlist))
    660                     (list (if (null? rargs)
    661                               (qnode '())
    662                               (make-node
    663                                '##core#inline_allocate
    664                                (list "C_a_i_list" (* 3 (length rargs)))
    665                                rargs) )
    666                           body) )
     660                   ;; NOTE: If contraction happens before rest-op
     661                   ;; detection, we might needlessly build a list.
     662                   (let loop2 ((rarg-values rargs)
     663                               (rarg-aliases rarg-aliases))
     664                     (if (null? rarg-aliases)
     665                         (if (null? (db-get-list db rest 'references))
     666                             body
     667                             (make-node
     668                              'let (list (last rlist))
     669                              (list (if (null? rargs)
     670                                        (qnode '())
     671                                        (make-node
     672                                         '##core#inline_allocate
     673                                         (list "C_a_i_list" (* 3 (length rargs)))
     674                                         rargs) )
     675                                    body) ))
     676                         (make-node 'let (list (car rarg-aliases))
     677                                    (list (car rarg-values)
     678                                          (loop2 (cdr rarg-values) (cdr rarg-aliases))))))
    667679                   body)
    668680               (make-node 'let (list (car vars))
    669681                          (list (car vals)
     
    718730                           (map (cut walk <> rl) subs))) ) ) )
    719731    (walk node rlist) ) )
    720732
     733;; Replace rest-{car,cdr,null?} with equivalent code which accesses
     734;; the rest argument directly.
     735(define (replace-rest-ops-in-known-call! db node rest-var rest-alias rest-args)
     736  (define (walk n)
     737    (let ((subs (node-subexpressions n))
     738          (params (node-parameters n))
     739          (class (node-class n)) )
     740      (case class
     741        ((##core#rest-null?)
     742         (if (eq? rest-var (first params))
     743             (copy-node! (qnode (<= (length rest-args) (second params))) n)
     744             n))
     745        ((##core#rest-car)
     746         (if (eq? rest-var (first params))
     747             (let ((depth (second params))
     748                   (len (length rest-args)))
     749               (if (> len depth)
     750                   (copy-node! (varnode (list-ref rest-args depth)) n)
     751                   ;; Emit code which will crash at runtime, because
     752                   ;; there aren't enough arguments...
     753                   (copy-node! (make-node '##core#inline
     754                                          (list (if (= len depth) "C_i_car" "C_i_cdr"))
     755                                          (list (qnode '())))
     756                               n)))
     757             n))
     758        ((##core#rest-cdr)
     759         (cond ((eq? rest-var (first params))
     760                (collect! db rest-var 'references n) ; Restore this reference
     761                (let lp ((i (add1 (second params)))
     762                         (new-node (varnode rest-alias)))
     763                  (if (zero? i)
     764                      (copy-node! new-node n)
     765                      (lp (sub1 i)
     766                          (make-node '##core#inline (list "C_i_cdr") (list new-node))))))
     767               (else n)))
     768        (else (for-each walk subs)) ) ) )
     769
     770  (walk node)  )
     771
    721772;; Maybe move to scrutinizer.  It's generic enough to keep it here though
    722773(define (tree-copy t)
    723774  (let rec ([t t])
  • tests/syntax-tests.scm

    diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
    index 1c98d94c..68c08483 100644
    a b  
    864864
    865865(assert (equal? '(3 4 5 (6 7)) (test-optional&rest 3 4 5 6 7)))
    866866
     867(define (test-optional&rest-cdrs x y #!optional z #!rest r)
     868  (list x y z (cdr (cdr r))))
     869
     870(assert (equal? '(3 4 5 ()) (test-optional&rest-cdrs 3 4 5 6 7)))
     871
     872;; Ensure that rest conversion is not applied too aggressively.
     873;; (only when the consequence is () should it be applied)
     874(define (rest-nonnull-optimization . rest)
     875  (let ((x (if (null? (cdr rest))
     876               '(foo)
     877               (cdr rest))))
     878    (null? x)))
     879
     880(assert (not (rest-nonnull-optimization 1)))
     881(assert (not (rest-nonnull-optimization 1 2)))
     882
     883(assert (equal? '(3 4 5 ()) (test-optional&rest-cdrs 3 4 5 6 7)))
     884
    867885(define (test-optional&key x y #!optional z #!key i (j 1))
    868886  (list x y z i: i j: j))
    869887