module/language/cps/self-references.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013, 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 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 ($ $kentry src meta self tail clause))
  39        (label ($kentry 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 ($ $void) ($ $const) ($ $prim)) ,exp)
  60       (($ $fun) ,(resolve-self-references exp env))
  61       (($ $call proc args)
  62        ($call (subst proc) ,(map subst args)))
  63       (($ $callk k proc args)
  64        ($callk k (subst proc) ,(map subst args)))
  65       (($ $primcall name args)
  66        ($primcall name ,(map subst args)))
  67       (($ $values args)
  68        ($values ,(map subst args)))
  69       (($ $prompt escape? tag handler)
  70        ($prompt escape? (subst tag) handler))))
  71
  72   (define (visit-recursive-fun fun var)
  73     (match fun
  74       (($ $fun free (and cont ($ $cont _ ($ $kentry src meta self))))
  75        (resolve-self-references fun (acons var self env)))))
  76
  77   (rewrite-cps-exp fun
  78     (($ $fun free cont)
  79      ($fun (map subst free) ,(visit-cont cont)))))