From f05517b24e65e0b14f29c57ad0c83ade9d7f1f14 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 30 Mar 2014 19:09:40 +0200 Subject: [PATCH] Add renumber module * module/language/cps/renumber.scm: New module. * module/Makefile.am: Add to build. fix renumber --- module/Makefile.am | 1 + module/language/cps/renumber.scm | 177 +++++++++++++++++++++++++++++++ 2 files changed, 178 insertions(+) create mode 100644 module/language/cps/renumber.scm diff --git a/module/Makefile.am b/module/Makefile.am index 42ee4b232..0e2ce6dd2 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -131,6 +131,7 @@ CPS_LANG_SOURCES = \ language/cps/primitives.scm \ language/cps/prune-top-level-scopes.scm \ language/cps/reify-primitives.scm \ + language/cps/renumber.scm \ language/cps/slot-allocation.scm \ language/cps/simplify.scm \ language/cps/spec.scm \ diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm new file mode 100644 index 000000000..9f1cc26e5 --- /dev/null +++ b/module/language/cps/renumber.scm @@ -0,0 +1,177 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2014 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A pass to renumber variables and continuation labels so that they +;;; are contiguous within each function. +;;; +;;; Code: + +(define-module (language cps renumber) + #:use-module (ice-9 match) + #:use-module (language cps) + #:export (renumber)) + +(define (visit-funs proc fun) + (define (visit-cont cont) + (match cont + (($ $cont label cont) + (match cont + (($ $kargs names vars body) + (visit-term body)) + (($ $kentry self tail clauses) + (for-each visit-cont clauses)) + (($ $kclause arity body) + (visit-cont body)) + ((or ($ $kreceive) ($ $kif)) + #f))))) + (define (visit-term term) + (match term + (($ $letk conts body) + (for-each visit-cont conts) + (visit-term body)) + (($ $letrec names syms funs body) + (for-each visit-fun funs) + (visit-term body)) + (($ $continue k src (and fun ($ $fun))) + (visit-fun fun)) + (($ $continue k src _) + #f))) + (define (visit-fun fun) + (proc fun) + (match fun + (($ $fun src meta free body) + (visit-cont body)))) + (visit-fun fun)) + +(define (compute-new-labels-and-vars fun) + (call-with-values (lambda () (compute-max-label-and-var fun)) + (lambda (max-label max-var) + (let ((labels (make-vector (1+ max-label))) + (next-label 0) + (vars (make-vector (1+ max-var))) + (next-var 0)) + (define (relabel! label) + (vector-set! labels label next-label) + (set! next-label (1+ next-label))) + (define (rename! var) + (vector-set! vars var next-var) + (set! next-var (1+ next-var))) + (define (compute-names-in-fun fun) + (define (visit-cont cont) + (match cont + (($ $cont label cont) + (relabel! label) + (match cont + (($ $kargs names vars body) + (for-each rename! vars) + (visit-term body)) + (($ $kentry self tail clauses) + (rename! self) + (visit-cont tail) + (for-each visit-cont clauses)) + (($ $kclause arity body) + (visit-cont body)) + ((or ($ $ktail) ($ $kreceive) ($ $kif)) + #f))))) + (define (visit-term term) + (match term + (($ $letk conts body) + (for-each visit-cont conts) + (visit-term body)) + (($ $letrec names syms funs body) + (for-each rename! syms) + (visit-term body)) + (($ $continue k src _) + #f))) + (match fun + (($ $fun src meta free body) + (visit-cont body)))) + + (visit-funs compute-names-in-fun fun) + (values labels vars))))) + +(define (renumber fun) + (call-with-values (lambda () (compute-new-labels-and-vars fun)) + (lambda (labels vars) + (define (relabel label) (vector-ref labels label)) + (define (rename var) (vector-ref vars var)) + (define (rename-kw-arity arity) + (match arity + (($ $arity req opt rest kw aok?) + (make-$arity req opt rest + (map (match-lambda + ((kw kw-name kw-var) + (list kw kw-name (rename kw-var)))) + kw) + aok?)))) + (define (visit-cont cont) + (rewrite-cps-cont cont + (($ $cont label ($ $kargs names vars body)) + ((relabel label) + ($kargs names (map rename vars) ,(visit-term body)))) + (($ $cont label ($ $kentry self tail clauses)) + ((relabel label) + ($kentry (rename self) ,(visit-cont tail) + ,(map visit-cont clauses)))) + (($ $cont label ($ $ktail)) + ((relabel label) ($ktail))) + (($ $cont label ($ $kclause arity body)) + ((relabel label) + ($kclause ,(rename-kw-arity arity) ,(visit-cont body)))) + (($ $cont label ($ $kreceive ($ $arity req () rest () #f) kargs)) + ((relabel label) ($kreceive req rest (relabel kargs)))) + (($ $cont label ($ $kif kt kf)) + ((relabel label) ($kif (relabel kt) (relabel kf)))))) + (define (visit-term term) + (rewrite-cps-term term + (($ $letk conts body) + ($letk ,(map visit-cont conts) + ,(visit-term body))) + (($ $letrec names vars funs body) + ($letrec names (map rename vars) (map visit-fun funs) + ,(visit-term body))) + (($ $continue k src exp) + ($continue (relabel k) src ,(visit-exp exp))))) + (define (visit-exp exp) + (match exp + ((or ($ $void) ($ $const) ($ $prim)) + exp) + (($ $fun) + (visit-fun exp)) + (($ $values args) + (let ((args (map rename args))) + (build-cps-exp ($values args)))) + (($ $call proc args) + (let ((args (map rename args))) + (build-cps-exp ($call (rename proc) args)))) + (($ $callk k proc args) + (let ((args (map rename args))) + (build-cps-exp ($callk (relabel k) (rename proc) args)))) + (($ $primcall name args) + (let ((args (map rename args))) + (build-cps-exp ($primcall name args)))) + (($ $prompt escape? tag handler) + (build-cps-exp + ($prompt escape? (rename tag) (relabel handler)))))) + (define (visit-fun fun) + (rewrite-cps-exp fun + (($ $fun src meta free body) + ($fun src meta (map rename free) ,(visit-cont body))))) + (visit-fun fun))))