module/language/cps/renumber.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Commentary:
  20 ;;;
  21 ;;; A pass to renumber variables and continuation labels so that they
  22 ;;; are contiguous within each function and, in the case of labels,
  23 ;;; topologically sorted.
  24 ;;;
  25 ;;; Code:
  26
  27 (define-module (language cps renumber)
  28   #:use-module (ice-9 match)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (language cps)
  31   #:export (renumber))
  32
  33 ;; Topologically sort the continuation tree starting at k0, using
  34 ;; reverse post-order numbering.
  35 (define (sort-conts k0 conts new-k0 path-lengths)
  36   (let ((next -1))
  37     (let visit ((k k0))
  38       (define (maybe-visit k)
  39         (let ((entry (vector-ref conts k)))
  40           ;; Visit the successor if it has not been
  41           ;; visited yet.
  42           (when (and entry (not (exact-integer? entry)))
  43             (visit k))))
  44
  45       (let ((cont (vector-ref conts k)))
  46         ;; Clear the cont table entry to mark this continuation as
  47         ;; visited.
  48         (vector-set! conts k #f)
  49
  50         (match cont
  51           (($ $kargs names syms body)
  52            (let lp ((body body))
  53              (match body
  54                (($ $letk conts body) (lp body))
  55                (($ $letrec names syms funs body) (lp body))
  56                (($ $continue k src exp)
  57                 (match exp
  58                   (($ $prompt escape? tag handler)
  59                    (maybe-visit handler)
  60                    (maybe-visit k))
  61                   (($ $branch kt)
  62                    ;; Visit the successor with the shortest path length
  63                    ;; to the tail first, so that if the branches are
  64                    ;; unsorted, the longer path length will appear
  65                    ;; first.  This will move a loop exit out of a loop.
  66                    (let ((k-len (vector-ref path-lengths k))
  67                          (kt-len (vector-ref path-lengths kt)))
  68                      (cond
  69                       ((if kt-len
  70                            (or (not k-len)
  71                                (< k-len kt-len)
  72                                ;; If the path lengths are the
  73                                ;; same, preserve original order
  74                                ;; to avoid squirreliness.
  75                                (and (= k-len kt-len) (< kt k)))
  76                            (if k-len #f (< kt k)))
  77                        (maybe-visit k)
  78                        (maybe-visit kt))
  79                       (else
  80                        (maybe-visit kt)
  81                        (maybe-visit k)))))
  82                   (_
  83                    (maybe-visit k)))))))
  84           (($ $kreceive arity k) (maybe-visit k))
  85           (($ $kclause arity ($ $cont kbody) alt)
  86            (match alt
  87              (($ $cont kalt) (maybe-visit kalt))
  88              (_ #f))
  89            (maybe-visit kbody))
  90           (($ $kfun src meta self tail clause)
  91            (match clause
  92              (($ $cont kclause) (maybe-visit kclause))
  93              (_ #f)))
  94           (_ #f))
  95
  96         ;; Chain this label to the label that will follow it in the sort
  97         ;; order, and record this label as the new head of the order.
  98         (vector-set! conts k next)
  99         (set! next k)))
 100
 101     ;; Finally traverse the label chain, giving each label its final
 102     ;; name.
 103     (let lp ((n new-k0) (head next))
 104       (if (< head 0)
 105           n
 106           (let ((next (vector-ref conts head)))
 107             (vector-set! conts head n)
 108             (lp (1+ n) next))))))
 109
 110 (define (compute-tail-path-lengths preds ktail path-lengths)
 111   (let visit ((k ktail) (length-in 0))
 112     (let ((length (vector-ref path-lengths k)))
 113       (unless (and length (<= length length-in))
 114         (vector-set! path-lengths k length-in)
 115         (let lp ((preds (vector-ref preds k)))
 116           (match preds
 117             (() #t)
 118             ((pred . preds)
 119              (visit pred (1+ length-in))
 120              (lp preds))))))))
 121
 122 (define (compute-new-labels-and-vars fun)
 123   (call-with-values (lambda () (compute-max-label-and-var fun))
 124     (lambda (max-label max-var)
 125       (let ((labels (make-vector (1+ max-label) #f))
 126             (next-label 0)
 127             (vars (make-vector (1+ max-var) #f))
 128             (next-var 0)
 129             (preds (make-vector (1+ max-label) '()))
 130             (path-lengths (make-vector (1+ max-label) #f)))
 131         (define (add-predecessor! pred succ)
 132           (vector-set! preds succ (cons pred (vector-ref preds succ))))
 133         (define (rename! var)
 134           (vector-set! vars var next-var)
 135           (set! next-var (1+ next-var)))
 136
 137         (define (collect-conts fun)
 138           (define (visit-cont cont)
 139             (match cont
 140               (($ $cont label cont)
 141                (vector-set! labels label cont)
 142                (match cont
 143                  (($ $kargs names vars body)
 144                   (visit-term body label))
 145                  (($ $kfun src meta self tail clause)
 146                   (visit-cont tail)
 147                   (match clause
 148                     (($ $cont kclause)
 149                      (add-predecessor! label kclause)
 150                      (visit-cont clause))
 151                     (#f #f)))
 152                  (($ $kclause arity (and body ($ $cont kbody)) alternate)
 153                   (add-predecessor! label kbody)
 154                   (visit-cont body)
 155                   (match alternate
 156                     (($ $cont kalt)
 157                      (add-predecessor! label kalt)
 158                      (visit-cont alternate))
 159                     (#f #f)))
 160                  (($ $kreceive arity kargs)
 161                   (add-predecessor! label kargs))
 162                  (($ $ktail) #f)))))
 163           (define (visit-term term label)
 164             (match term
 165               (($ $letk conts body)
 166                (let lp ((conts conts))
 167                  (unless (null? conts)
 168                    (visit-cont (car conts))
 169                    (lp (cdr conts))))
 170                (visit-term body label))
 171               (($ $letrec names syms funs body)
 172                (visit-term body label))
 173               (($ $continue k src exp)
 174                (add-predecessor! label k)
 175                (match exp
 176                  (($ $branch kt)
 177                   (add-predecessor! label kt))
 178                  (($ $prompt escape? tag handler)
 179                   (add-predecessor! label handler))
 180                  (_ #f)))))
 181           (visit-cont fun))
 182
 183         (define (compute-names-in-fun fun)
 184           (define queue '())
 185           (define (visit-cont cont)
 186             (match cont
 187               (($ $cont label cont)
 188                (let ((reachable? (exact-integer? (vector-ref labels label))))
 189                  ;; This cont is reachable if it was given a number.
 190                  ;; Otherwise the cont table entry still contains the
 191                  ;; cont itself; clear it out to indicate that the cont
 192                  ;; should not be residualized.
 193                  (unless reachable?
 194                    (vector-set! labels label #f))
 195                  (match cont
 196                    (($ $kargs names vars body)
 197                     (when reachable?
 198                       (for-each rename! vars))
 199                     (visit-term body reachable?))
 200                    (($ $kfun src meta self tail clause)
 201                     (unless reachable? (error "entry should be reachable"))
 202                     (rename! self)
 203                     (visit-cont tail)
 204                     (when clause
 205                       (visit-cont clause)))
 206                    (($ $kclause arity body alternate)
 207                     (unless reachable? (error "clause should be reachable"))
 208                     (visit-cont body)
 209                     (when alternate
 210                       (visit-cont alternate)))
 211                    (($ $ktail)
 212                     (unless reachable?
 213                       ;; It's possible for the tail to be unreachable,
 214                       ;; if all paths contify to infinite loops.  Make
 215                       ;; sure we mark as reachable.
 216                       (vector-set! labels label next-label)
 217                       (set! next-label (1+ next-label))))
 218                    (($ $kreceive)
 219                     #f))))))
 220           (define (visit-term term reachable?)
 221             (match term
 222               (($ $letk conts body)
 223                (for-each visit-cont conts)
 224                (visit-term body reachable?))
 225               (($ $letrec names syms funs body)
 226                (when reachable?
 227                  (for-each rename! syms)
 228                  (set! queue (fold (lambda (fun queue)
 229                                      (match fun
 230                                        (($ $fun free body)
 231                                         (cons body queue))))
 232                                    queue
 233                                    funs)))
 234                (visit-term body reachable?))
 235               (($ $continue k src ($ $fun free body))
 236                (when reachable?
 237                  (set! queue (cons body queue))))
 238               (($ $continue) #f)))
 239
 240           (match fun
 241             (($ $cont kfun ($ $kfun src meta self ($ $cont ktail)))
 242              (collect-conts fun)
 243              (compute-tail-path-lengths preds ktail path-lengths)
 244              (set! next-label (sort-conts kfun labels next-label path-lengths))
 245              (visit-cont fun)
 246              (for-each compute-names-in-fun (reverse queue)))
 247             (($ $program conts)
 248              (for-each compute-names-in-fun conts))))
 249
 250         (compute-names-in-fun fun)
 251         (values labels vars next-label next-var)))))
 252
 253 (define (apply-renumbering term labels vars)
 254   (define (relabel label) (vector-ref labels label))
 255   (define (rename var) (vector-ref vars var))
 256   (define (rename-kw-arity arity)
 257     (match arity
 258       (($ $arity req opt rest kw aok?)
 259        (make-$arity req opt rest
 260                     (map (match-lambda
 261                           ((kw kw-name kw-var)
 262                            (list kw kw-name (rename kw-var))))
 263                          kw)
 264                     aok?))))
 265   (define (must-visit-cont cont)
 266     (or (visit-cont cont)
 267         (error "internal error -- failed to visit cont")))
 268   (define (visit-conts conts)
 269     (match conts
 270       (() '())
 271       ((cont . conts)
 272        (cond
 273         ((visit-cont cont)
 274          => (lambda (cont)
 275               (cons cont (visit-conts conts))))
 276         (else (visit-conts conts))))))
 277   (define (visit-cont cont)
 278     (match cont
 279       (($ $cont label cont)
 280        (let ((label (relabel label)))
 281          (and
 282           label
 283           (rewrite-cps-cont cont
 284             (($ $kargs names vars body)
 285              (label ($kargs names (map rename vars) ,(visit-term body))))
 286             (($ $kfun src meta self tail clause)
 287              (label
 288               ($kfun src meta (rename self) ,(must-visit-cont tail)
 289                 ,(and clause (must-visit-cont clause)))))
 290             (($ $ktail)
 291              (label ($ktail)))
 292             (($ $kclause arity body alternate)
 293              (label
 294               ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
 295                         ,(and alternate (must-visit-cont alternate)))))
 296             (($ $kreceive ($ $arity req () rest () #f) kargs)
 297              (label ($kreceive req rest (relabel kargs))))))))))
 298   (define (visit-term term)
 299     (rewrite-cps-term term
 300       (($ $letk conts body)
 301        ,(match (visit-conts conts)
 302           (() (visit-term body))
 303           (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
 304       (($ $letrec names vars funs body)
 305        ($letrec names (map rename vars) (map visit-fun funs)
 306          ,(visit-term body)))
 307       (($ $continue k src exp)
 308        ($continue (relabel k) src ,(visit-exp exp)))))
 309   (define (visit-exp exp)
 310     (match exp
 311       ((or ($ $const) ($ $prim))
 312        exp)
 313       (($ $closure k nfree)
 314        (build-cps-exp ($closure (relabel k) nfree)))
 315       (($ $fun)
 316        (visit-fun exp))
 317       (($ $values args)
 318        (let ((args (map rename args)))
 319          (build-cps-exp ($values args))))
 320       (($ $call proc args)
 321        (let ((args (map rename args)))
 322          (build-cps-exp ($call (rename proc) args))))
 323       (($ $callk k proc args)
 324        (let ((args (map rename args)))
 325          (build-cps-exp ($callk (relabel k) (rename proc) args))))
 326       (($ $branch kt exp)
 327        (build-cps-exp ($branch (relabel kt) ,(visit-exp exp))))
 328       (($ $primcall name args)
 329        (let ((args (map rename args)))
 330          (build-cps-exp ($primcall name args))))
 331       (($ $prompt escape? tag handler)
 332        (build-cps-exp
 333          ($prompt escape? (rename tag) (relabel handler))))))
 334   (define (visit-fun fun)
 335     (rewrite-cps-exp fun
 336       (($ $fun free body)
 337        ($fun (map rename free) ,(must-visit-cont body)))))
 338
 339   (match term
 340     (($ $cont)
 341      (must-visit-cont term))
 342     (($ $program conts)
 343      (build-cps-term
 344        ($program ,(map must-visit-cont conts))))))
 345
 346 (define (renumber term)
 347   (call-with-values (lambda () (compute-new-labels-and-vars term))
 348     (lambda (labels vars nlabels nvars)
 349       (values (apply-renumbering term labels vars) nlabels nvars))))