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.
  23 ;;;
  24 ;;; Code:
  25
  26 (define-module (language cps renumber)
  27   #:use-module (ice-9 match)
  28   #:use-module (language cps)
  29   #:export (renumber))
  30
  31 (define (visit-funs proc fun)
  32   (define (visit-cont cont)
  33     (match cont
  34       (($ $cont label cont)
  35        (match cont
  36          (($ $kargs names vars body)
  37           (visit-term body))
  38          (($ $kentry self tail clauses)
  39           (for-each visit-cont clauses))
  40          (($ $kclause arity body)
  41           (visit-cont body))
  42          ((or ($ $kreceive) ($ $kif))
  43           #f)))))
  44   (define (visit-term term)
  45     (match term
  46       (($ $letk conts body)
  47        (for-each visit-cont conts)
  48        (visit-term body))
  49       (($ $letrec names syms funs body)
  50        (for-each visit-fun funs)
  51        (visit-term body))
  52       (($ $continue k src (and fun ($ $fun)))
  53        (visit-fun fun))
  54       (($ $continue k src _)
  55        #f)))
  56   (define (visit-fun fun)
  57     (proc fun)
  58     (match fun
  59       (($ $fun src meta free body)
  60        (visit-cont body))))
  61   (visit-fun fun))
  62
  63 (define (compute-new-labels-and-vars fun)
  64   (call-with-values (lambda () (compute-max-label-and-var fun))
  65     (lambda (max-label max-var)
  66       (let ((labels (make-vector (1+ max-label)))
  67             (next-label 0)
  68             (vars (make-vector (1+ max-var)))
  69             (next-var 0))
  70         (define (relabel! label)
  71           (vector-set! labels label next-label)
  72           (set! next-label (1+ next-label)))
  73         (define (rename! var)
  74           (vector-set! vars var next-var)
  75           (set! next-var (1+ next-var)))
  76         (define (compute-names-in-fun fun)
  77           (define (visit-cont cont)
  78             (match cont
  79               (($ $cont label cont)
  80                (relabel! label)
  81                (match cont
  82                  (($ $kargs names vars body)
  83                   (for-each rename! vars)
  84                   (visit-term body))
  85                  (($ $kentry self tail clauses)
  86                   (rename! self)
  87                   (visit-cont tail)
  88                   (for-each visit-cont clauses))
  89                  (($ $kclause arity body)
  90                   (visit-cont body))
  91                  ((or ($ $ktail) ($ $kreceive) ($ $kif))
  92                   #f)))))
  93           (define (visit-term term)
  94             (match term
  95               (($ $letk conts body)
  96                (for-each visit-cont conts)
  97                (visit-term body))
  98               (($ $letrec names syms funs body)
  99                (for-each rename! syms)
 100                (visit-term body))
 101               (($ $continue k src _)
 102                #f)))
 103           (match fun
 104             (($ $fun src meta free body)
 105              (visit-cont body))))
 106
 107         (visit-funs compute-names-in-fun fun)
 108         (values labels vars)))))
 109
 110 (define (renumber fun)
 111   (call-with-values (lambda () (compute-new-labels-and-vars fun))
 112     (lambda (labels vars)
 113       (define (relabel label) (vector-ref labels label))
 114       (define (rename var) (vector-ref vars var))
 115       (define (rename-kw-arity arity)
 116         (match arity
 117           (($ $arity req opt rest kw aok?)
 118            (make-$arity req opt rest
 119                         (map (match-lambda
 120                               ((kw kw-name kw-var)
 121                                (list kw kw-name (rename kw-var))))
 122                              kw)
 123                         aok?))))
 124       (define (visit-cont cont)
 125         (rewrite-cps-cont cont
 126           (($ $cont label ($ $kargs names vars body))
 127            ((relabel label)
 128             ($kargs names (map rename vars) ,(visit-term body))))
 129           (($ $cont label ($ $kentry self tail clauses))
 130            ((relabel label)
 131             ($kentry (rename self) ,(visit-cont tail)
 132               ,(map visit-cont clauses))))
 133           (($ $cont label ($ $ktail))
 134            ((relabel label) ($ktail)))
 135           (($ $cont label ($ $kclause arity body))
 136            ((relabel label)
 137             ($kclause ,(rename-kw-arity arity) ,(visit-cont body))))
 138           (($ $cont label ($ $kreceive ($ $arity req () rest () #f) kargs))
 139            ((relabel label) ($kreceive req rest (relabel kargs))))
 140           (($ $cont label ($ $kif kt kf))
 141            ((relabel label) ($kif (relabel kt) (relabel kf))))))
 142       (define (visit-term term)
 143         (rewrite-cps-term term
 144           (($ $letk conts body)
 145            ($letk ,(map visit-cont conts)
 146              ,(visit-term body)))
 147           (($ $letrec names vars funs body)
 148            ($letrec names (map rename vars) (map visit-fun funs)
 149                     ,(visit-term body)))
 150           (($ $continue k src exp)
 151            ($continue (relabel k) src ,(visit-exp exp)))))
 152       (define (visit-exp exp)
 153         (match exp
 154           ((or ($ $void) ($ $const) ($ $prim))
 155            exp)
 156           (($ $fun)
 157            (visit-fun exp))
 158           (($ $values args)
 159            (let ((args (map rename args)))
 160               (build-cps-exp ($values args))))
 161           (($ $call proc args)
 162            (let ((args (map rename args)))
 163               (build-cps-exp ($call (rename proc) args))))
 164           (($ $callk k proc args)
 165            (let ((args (map rename args)))
 166               (build-cps-exp ($callk (relabel k) (rename proc) args))))
 167           (($ $primcall name args)
 168            (let ((args (map rename args)))
 169               (build-cps-exp ($primcall name args))))
 170           (($ $prompt escape? tag handler)
 171            (build-cps-exp
 172              ($prompt escape? (rename tag) (relabel handler))))))
 173       (define (visit-fun fun)
 174         (rewrite-cps-exp fun
 175           (($ $fun src meta free body)
 176            ($fun src meta (map rename free) ,(visit-cont body)))))
 177       (visit-fun fun))))