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                (($ $continue k src exp)
  56                 (match exp
  57                   (($ $prompt escape? tag handler)
  58                    (maybe-visit handler)
  59                    (maybe-visit k))
  60                   (($ $branch kt)
  61                    ;; Visit the successor with the shortest path length
  62                    ;; to the tail first, so that if the branches are
  63                    ;; unsorted, the longer path length will appear
  64                    ;; first.  This will move a loop exit out of a loop.
  65                    (let ((k-len (vector-ref path-lengths k))
  66                          (kt-len (vector-ref path-lengths kt)))
  67                      (cond
  68                       ((if kt-len
  69                            (or (not k-len)
  70                                (< k-len kt-len)
  71                                ;; If the path lengths are the
  72                                ;; same, preserve original order
  73                                ;; to avoid squirreliness.
  74                                (and (= k-len kt-len) (< kt k)))
  75                            (if k-len #f (< kt k)))
  76                        (maybe-visit k)
  77                        (maybe-visit kt))
  78                       (else
  79                        (maybe-visit kt)
  80                        (maybe-visit k)))))
  81                   (_
  82                    (maybe-visit k)))))))
  83           (($ $kreceive arity k) (maybe-visit k))
  84           (($ $kclause arity ($ $cont kbody) alt)
  85            (match alt
  86              (($ $cont kalt) (maybe-visit kalt))
  87              (_ #f))
  88            (maybe-visit kbody))
  89           (($ $kfun src meta self tail clause)
  90            (match clause
  91              (($ $cont kclause) (maybe-visit kclause))
  92              (_ #f)))
  93           (_ #f))
  94
  95         ;; Chain this label to the label that will follow it in the sort
  96         ;; order, and record this label as the new head of the order.
  97         (vector-set! conts k next)
  98         (set! next k)))
  99
 100     ;; Finally traverse the label chain, giving each label its final
 101     ;; name.
 102     (let lp ((n new-k0) (head next))
 103       (if (< head 0)
 104           n
 105           (let ((next (vector-ref conts head)))
 106             (vector-set! conts head n)
 107             (lp (1+ n) next))))))
 108
 109 (define (compute-tail-path-lengths preds ktail path-lengths)
 110   (let visit ((k ktail) (length-in 0))
 111     (let ((length (vector-ref path-lengths k)))
 112       (unless (and length (<= length length-in))
 113         (vector-set! path-lengths k length-in)
 114         (let lp ((preds (vector-ref preds k)))
 115           (match preds
 116             (() #t)
 117             ((pred . preds)
 118              (visit pred (1+ length-in))
 119              (lp preds))))))))
 120
 121 (define (compute-new-labels-and-vars fun)
 122   (call-with-values (lambda () (compute-max-label-and-var fun))
 123     (lambda (max-label max-var)
 124       (let ((labels (make-vector (1+ max-label) #f))
 125             (next-label 0)
 126             (vars (make-vector (1+ max-var) #f))
 127             (next-var 0)
 128             (preds (make-vector (1+ max-label) '()))
 129             (path-lengths (make-vector (1+ max-label) #f)))
 130         (define (add-predecessor! pred succ)
 131           (vector-set! preds succ (cons pred (vector-ref preds succ))))
 132         (define (rename! var)
 133           (vector-set! vars var next-var)
 134           (set! next-var (1+ next-var)))
 135
 136         (define (collect-conts fun)
 137           (define (visit-cont cont)
 138             (match cont
 139               (($ $cont label cont)
 140                (vector-set! labels label cont)
 141                (match cont
 142                  (($ $kargs names vars body)
 143                   (visit-term body label))
 144                  (($ $kfun src meta self tail clause)
 145                   (visit-cont tail)
 146                   (match clause
 147                     (($ $cont kclause)
 148                      (add-predecessor! label kclause)
 149                      (visit-cont clause))
 150                     (#f #f)))
 151                  (($ $kclause arity (and body ($ $cont kbody)) alternate)
 152                   (add-predecessor! label kbody)
 153                   (visit-cont body)
 154                   (match alternate
 155                     (($ $cont kalt)
 156                      (add-predecessor! label kalt)
 157                      (visit-cont alternate))
 158                     (#f #f)))
 159                  (($ $kreceive arity kargs)
 160                   (add-predecessor! label kargs))
 161                  (($ $ktail) #f)))))
 162           (define (visit-term term label)
 163             (match term
 164               (($ $letk conts body)
 165                (let lp ((conts conts))
 166                  (unless (null? conts)
 167                    (visit-cont (car conts))
 168                    (lp (cdr conts))))
 169                (visit-term body label))
 170               (($ $continue k src exp)
 171                (add-predecessor! label k)
 172                (match exp
 173                  (($ $branch kt)
 174                   (add-predecessor! label kt))
 175                  (($ $prompt escape? tag handler)
 176                   (add-predecessor! label handler))
 177                  (_ #f)))))
 178           (visit-cont fun))
 179
 180         (define (compute-names-in-fun fun)
 181           (define queue '())
 182           (define (visit-cont cont)
 183             (match cont
 184               (($ $cont label cont)
 185                (let ((reachable? (exact-integer? (vector-ref labels label))))
 186                  ;; This cont is reachable if it was given a number.
 187                  ;; Otherwise the cont table entry still contains the
 188                  ;; cont itself; clear it out to indicate that the cont
 189                  ;; should not be residualized.
 190                  (unless reachable?
 191                    (vector-set! labels label #f))
 192                  (match cont
 193                    (($ $kargs names vars body)
 194                     (when reachable?
 195                       (for-each rename! vars))
 196                     (visit-term body reachable?))
 197                    (($ $kfun src meta self tail clause)
 198                     (unless reachable? (error "entry should be reachable"))
 199                     (rename! self)
 200                     (visit-cont tail)
 201                     (when clause
 202                       (visit-cont clause)))
 203                    (($ $kclause arity body alternate)
 204                     (unless reachable? (error "clause should be reachable"))
 205                     (visit-cont body)
 206                     (when alternate
 207                       (visit-cont alternate)))
 208                    (($ $ktail)
 209                     (unless reachable?
 210                       ;; It's possible for the tail to be unreachable,
 211                       ;; if all paths contify to infinite loops.  Make
 212                       ;; sure we mark as reachable.
 213                       (vector-set! labels label next-label)
 214                       (set! next-label (1+ next-label))))
 215                    (($ $kreceive)
 216                     #f))))))
 217           (define (visit-term term reachable?)
 218             (match term
 219               (($ $letk conts body)
 220                (for-each visit-cont conts)
 221                (visit-term body reachable?))
 222               (($ $continue k src ($ $fun body))
 223                (when reachable?
 224                  (set! queue (cons body queue))))
 225               (($ $continue k src ($ $rec names syms funs))
 226                (when reachable?
 227                  (set! queue (fold (lambda (fun queue)
 228                                      (match fun
 229                                        (($ $fun body)
 230                                         (cons body queue))))
 231                                    queue
 232                                    funs))))
 233               (($ $continue) #f)))
 234
 235           (match fun
 236             (($ $cont kfun ($ $kfun src meta self ($ $cont ktail)))
 237              (collect-conts fun)
 238              (compute-tail-path-lengths preds ktail path-lengths)
 239              (set! next-label (sort-conts kfun labels next-label path-lengths))
 240              (visit-cont fun)
 241              (for-each compute-names-in-fun (reverse queue)))
 242             (($ $program conts)
 243              (for-each compute-names-in-fun conts))))
 244
 245         (compute-names-in-fun fun)
 246         (values labels vars next-label next-var)))))
 247
 248 (define (apply-renumbering term labels vars)
 249   (define (relabel label) (vector-ref labels label))
 250   (define (rename var) (vector-ref vars var))
 251   (define (rename-kw-arity arity)
 252     (match arity
 253       (($ $arity req opt rest kw aok?)
 254        (make-$arity req opt rest
 255                     (map (match-lambda
 256                           ((kw kw-name kw-var)
 257                            (list kw kw-name (rename kw-var))))
 258                          kw)
 259                     aok?))))
 260   (define (must-visit-cont cont)
 261     (or (visit-cont cont)
 262         (error "internal error -- failed to visit cont")))
 263   (define (visit-conts conts)
 264     (match conts
 265       (() '())
 266       ((cont . conts)
 267        (cond
 268         ((visit-cont cont)
 269          => (lambda (cont)
 270               (cons cont (visit-conts conts))))
 271         (else (visit-conts conts))))))
 272   (define (visit-cont cont)
 273     (match cont
 274       (($ $cont label cont)
 275        (let ((label (relabel label)))
 276          (and
 277           label
 278           (rewrite-cps-cont cont
 279             (($ $kargs names vars body)
 280              (label ($kargs names (map rename vars) ,(visit-term body))))
 281             (($ $kfun src meta self tail clause)
 282              (label
 283               ($kfun src meta (rename self) ,(must-visit-cont tail)
 284                 ,(and clause (must-visit-cont clause)))))
 285             (($ $ktail)
 286              (label ($ktail)))
 287             (($ $kclause arity body alternate)
 288              (label
 289               ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
 290                         ,(and alternate (must-visit-cont alternate)))))
 291             (($ $kreceive ($ $arity req () rest () #f) kargs)
 292              (label ($kreceive req rest (relabel kargs))))))))))
 293   (define (visit-term term)
 294     (rewrite-cps-term term
 295       (($ $letk conts body)
 296        ,(match (visit-conts conts)
 297           (() (visit-term body))
 298           (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
 299       (($ $continue k src exp)
 300        ($continue (relabel k) src ,(visit-exp exp)))))
 301   (define (visit-exp exp)
 302     (match exp
 303       ((or ($ $const) ($ $prim))
 304        exp)
 305       (($ $closure k nfree)
 306        (build-cps-exp ($closure (relabel k) nfree)))
 307       (($ $fun)
 308        (visit-fun exp))
 309       (($ $rec names vars funs)
 310        (build-cps-exp ($rec names (map rename vars) (map visit-fun funs))))
 311       (($ $values args)
 312        (let ((args (map rename args)))
 313          (build-cps-exp ($values args))))
 314       (($ $call proc args)
 315        (let ((args (map rename args)))
 316          (build-cps-exp ($call (rename proc) args))))
 317       (($ $callk k proc args)
 318        (let ((args (map rename args)))
 319          (build-cps-exp ($callk (relabel k) (rename proc) args))))
 320       (($ $branch kt exp)
 321        (build-cps-exp ($branch (relabel kt) ,(visit-exp exp))))
 322       (($ $primcall name args)
 323        (let ((args (map rename args)))
 324          (build-cps-exp ($primcall name args))))
 325       (($ $prompt escape? tag handler)
 326        (build-cps-exp
 327          ($prompt escape? (rename tag) (relabel handler))))))
 328   (define (visit-fun fun)
 329     (rewrite-cps-exp fun
 330       (($ $fun body)
 331        ($fun ,(must-visit-cont body)))))
 332
 333   (match term
 334     (($ $cont)
 335      (must-visit-cont term))
 336     (($ $program conts)
 337      (build-cps-term
 338        ($program ,(map must-visit-cont conts))))))
 339
 340 (define (renumber term)
 341   (call-with-values (lambda () (compute-new-labels-and-vars term))
 342     (lambda (labels vars nlabels nvars)
 343       (values (apply-renumbering term labels vars) nlabels nvars))))