module/language/cps/renumber.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2014 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)
  36   (define (for-each-successor f cont)
  37     (visit-cont-successors
  38      (case-lambda
  39        (() #t)
  40        ((succ0) (f succ0))
  41        ((succ0 succ1)
  42         ;; Visit higher-numbered successors first, so that if they are
  43         ;; unordered, their original order is preserved.
  44         (cond
  45          ((< succ0 succ1) (f succ1) (f succ0))
  46          (else (f succ0) (f succ1)))))
  47      cont))
  48
  49   (let ((next -1))
  50     (let visit ((k k0))
  51       (let ((cont (vector-ref conts k)))
  52         ;; Clear the cont table entry to mark this continuation as
  53         ;; visited.
  54         (vector-set! conts k #f)
  55         (for-each-successor (lambda (k)
  56                               (let ((entry (vector-ref conts k)))
  57                                 ;; Visit the successor if it has not been
  58                                 ;; visited yet.
  59                                 (when (and entry (not (exact-integer? entry)))
  60                                   (visit k))))
  61                             cont)
  62         ;; Chain this label to the label that will follow it in the sort
  63         ;; order, and record this label as the new head of the order.
  64         (vector-set! conts k next)
  65         (set! next k)))
  66
  67     ;; Finally traverse the label chain, giving each label its final
  68     ;; name.
  69     (let lp ((n new-k0) (head next))
  70       (if (< head 0)
  71           n
  72           (let ((next (vector-ref conts head)))
  73             (vector-set! conts head n)
  74             (lp (1+ n) next))))))
  75
  76 (define (compute-new-labels-and-vars fun)
  77   (call-with-values (lambda () (compute-max-label-and-var fun))
  78     (lambda (max-label max-var)
  79       (let ((labels (make-vector (1+ max-label) #f))
  80             (next-label 0)
  81             (vars (make-vector (1+ max-var) #f))
  82             (next-var 0))
  83         (define (rename! var)
  84           (vector-set! vars var next-var)
  85           (set! next-var (1+ next-var)))
  86
  87         (define (collect-conts fun)
  88           (define (visit-cont cont)
  89             (match cont
  90               (($ $cont label cont)
  91                (vector-set! labels label cont)
  92                (match cont
  93                  (($ $kargs names vars body)
  94                   (visit-term body))
  95                  (($ $kfun src meta self tail clause)
  96                   (visit-cont tail)
  97                   (when clause
  98                     (visit-cont clause)))
  99                  (($ $kclause arity body alternate)
 100                   (visit-cont body)
 101                   (when alternate
 102                     (visit-cont alternate)))
 103                  ((or ($ $ktail) ($ $kreceive) ($ $kif))
 104                   #f)))))
 105           (define (visit-term term)
 106             (match term
 107               (($ $letk conts body)
 108                (for-each visit-cont conts)
 109                (visit-term body))
 110               (($ $letrec names syms funs body)
 111                (visit-term body))
 112               (($ $continue k src _) #f)))
 113           (match fun
 114             (($ $fun free body)
 115              (visit-cont body))))
 116
 117         (define (compute-names-in-fun fun)
 118           (define queue '())
 119           (define (visit-cont cont)
 120             (match cont
 121               (($ $cont label cont)
 122                (let ((reachable? (exact-integer? (vector-ref labels label))))
 123                  ;; This cont is reachable if it was given a number.
 124                  ;; Otherwise the cont table entry still contains the
 125                  ;; cont itself; clear it out to indicate that the cont
 126                  ;; should not be residualized.
 127                  (unless reachable?
 128                    (vector-set! labels label #f))
 129                  (match cont
 130                    (($ $kargs names vars body)
 131                     (when reachable?
 132                       (for-each rename! vars))
 133                     (visit-term body reachable?))
 134                    (($ $kfun src meta self tail clause)
 135                     (unless reachable? (error "entry should be reachable"))
 136                     (rename! self)
 137                     (visit-cont tail)
 138                     (when clause
 139                       (visit-cont clause)))
 140                    (($ $kclause arity body alternate)
 141                     (unless reachable? (error "clause should be reachable"))
 142                     (visit-cont body)
 143                     (when alternate
 144                       (visit-cont alternate)))
 145                    (($ $ktail)
 146                     (unless reachable?
 147                       ;; It's possible for the tail to be unreachable,
 148                       ;; if all paths contify to infinite loops.  Make
 149                       ;; sure we mark as reachable.
 150                       (vector-set! labels label next-label)
 151                       (set! next-label (1+ next-label))))
 152                    ((or ($ $kreceive) ($ $kif))
 153                     #f))))))
 154           (define (visit-term term reachable?)
 155             (match term
 156               (($ $letk conts body)
 157                (for-each visit-cont conts)
 158                (visit-term body reachable?))
 159               (($ $letrec names syms funs body)
 160                (when reachable?
 161                  (for-each rename! syms)
 162                  (set! queue (fold cons queue funs)))
 163                (visit-term body reachable?))
 164               (($ $continue k src (and fun ($ $fun)))
 165                (when reachable?
 166                  (set! queue (cons fun queue))))
 167               (($ $continue) #f)))
 168
 169           (collect-conts fun)
 170           (match fun
 171             (($ $fun free (and entry ($ $cont kfun)))
 172              (set! next-label (sort-conts kfun labels next-label))
 173              (visit-cont entry)
 174              (for-each compute-names-in-fun (reverse queue)))))
 175
 176         (compute-names-in-fun fun)
 177         (values labels vars next-label next-var)))))
 178
 179 (define (renumber fun)
 180   (call-with-values (lambda () (compute-new-labels-and-vars fun))
 181     (lambda (labels vars nlabels nvars)
 182       (define (relabel label) (vector-ref labels label))
 183       (define (rename var) (vector-ref vars var))
 184       (define (rename-kw-arity arity)
 185         (match arity
 186           (($ $arity req opt rest kw aok?)
 187            (make-$arity req opt rest
 188                         (map (match-lambda
 189                               ((kw kw-name kw-var)
 190                                (list kw kw-name (rename kw-var))))
 191                              kw)
 192                         aok?))))
 193       (define (must-visit-cont cont)
 194         (or (visit-cont cont)
 195             (error "internal error -- failed to visit cont")))
 196       (define (visit-conts conts)
 197         (match conts
 198           (() '())
 199           ((cont . conts)
 200            (cond
 201             ((visit-cont cont)
 202              => (lambda (cont)
 203                   (cons cont (visit-conts conts))))
 204             (else (visit-conts conts))))))
 205       (define (visit-cont cont)
 206         (match cont
 207           (($ $cont label cont)
 208            (let ((label (relabel label)))
 209              (and
 210               label
 211               (rewrite-cps-cont cont
 212                 (($ $kargs names vars body)
 213                  (label ($kargs names (map rename vars) ,(visit-term body))))
 214                 (($ $kfun src meta self tail clause)
 215                  (label
 216                   ($kfun src meta (rename self) ,(must-visit-cont tail)
 217                     ,(and clause (must-visit-cont clause)))))
 218                 (($ $ktail)
 219                  (label ($ktail)))
 220                 (($ $kclause arity body alternate)
 221                  (label
 222                   ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
 223                             ,(and alternate (must-visit-cont alternate)))))
 224                 (($ $kreceive ($ $arity req () rest () #f) kargs)
 225                  (label ($kreceive req rest (relabel kargs))))
 226                 (($ $kif kt kf)
 227                  (label ($kif (relabel kt) (relabel kf))))))))))
 228       (define (visit-term term)
 229         (rewrite-cps-term term
 230           (($ $letk conts body)
 231            ,(match (visit-conts conts)
 232               (() (visit-term body))
 233               (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
 234           (($ $letrec names vars funs body)
 235            ($letrec names (map rename vars) (map visit-fun funs)
 236                     ,(visit-term body)))
 237           (($ $continue k src exp)
 238            ($continue (relabel k) src ,(visit-exp exp)))))
 239       (define (visit-exp exp)
 240         (match exp
 241           ((or ($ $void) ($ $const) ($ $prim))
 242            exp)
 243           (($ $fun)
 244            (visit-fun exp))
 245           (($ $values args)
 246            (let ((args (map rename args)))
 247              (build-cps-exp ($values args))))
 248           (($ $call proc args)
 249            (let ((args (map rename args)))
 250              (build-cps-exp ($call (rename proc) args))))
 251           (($ $callk k proc args)
 252            (let ((args (map rename args)))
 253              (build-cps-exp ($callk (relabel k) (rename proc) args))))
 254           (($ $primcall name args)
 255            (let ((args (map rename args)))
 256              (build-cps-exp ($primcall name args))))
 257           (($ $prompt escape? tag handler)
 258            (build-cps-exp
 259              ($prompt escape? (rename tag) (relabel handler))))))
 260       (define (visit-fun fun)
 261         (rewrite-cps-exp fun
 262           (($ $fun free body)
 263            ($fun (map rename free) ,(must-visit-cont body)))))
 264       (values (visit-fun fun) nlabels nvars))))