module/language/cps/self-references.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013, 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 that prunes successors of expressions that bail out.
  22 ;;;
  23 ;;; Code:
  24
  25 (define-module (language cps self-references)
  26   #:use-module (ice-9 match)
  27   #:use-module (language cps)
  28   #:export (resolve-self-references))
  29
  30 (define* (resolve-self-references fun #:optional (env '()))
  31   (define (subst var)
  32     (or (assq-ref env var) var))
  33
  34   (define (visit-cont cont)
  35     (rewrite-cps-cont cont
  36       (($ $cont label ($ $kargs names vars body))
  37        (label ($kargs names vars ,(visit-term body))))
  38       (($ $cont label ($ $kfun src meta self tail clause))
  39        (label ($kfun src meta self ,tail
  40                 ,(and clause (visit-cont clause)))))
  41       (($ $cont label ($ $kclause arity body alternate))
  42        (label ($kclause ,arity ,(visit-cont body)
  43                         ,(and alternate (visit-cont alternate)))))
  44       (_ ,cont)))
  45
  46   (define (visit-term term)
  47     (rewrite-cps-term term
  48       (($ $letrec names vars funs body)
  49        ($letrec names vars (map visit-recursive-fun funs vars)
  50          ,(visit-term body)))
  51       (($ $letk conts body)
  52        ($letk ,(map visit-cont conts)
  53          ,(visit-term body)))
  54       (($ $continue k src exp)
  55        ($continue k src ,(visit-exp exp)))))
  56
  57   (define (visit-exp exp)
  58     (rewrite-cps-exp exp
  59       ((or ($ $const) ($ $prim)) ,exp)
  60       (($ $fun free body)
  61        ($fun free ,(resolve-self-references body env)))
  62       (($ $call proc args)
  63        ($call (subst proc) ,(map subst args)))
  64       (($ $callk k proc args)
  65        ($callk k (subst proc) ,(map subst args)))
  66       (($ $primcall name args)
  67        ($primcall name ,(map subst args)))
  68       (($ $branch k exp)
  69        ($branch k ,(visit-exp exp)))
  70       (($ $values args)
  71        ($values ,(map subst args)))
  72       (($ $prompt escape? tag handler)
  73        ($prompt escape? (subst tag) handler))))
  74
  75   (define (visit-recursive-fun fun var)
  76     (rewrite-cps-exp fun
  77       (($ $fun free (and cont ($ $cont _ ($ $kfun src meta self))))
  78        ($fun free ,(resolve-self-references cont (acons var self env))))))
  79
  80   (visit-cont fun))