mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-29 08:20:20 +02:00
Code Activity

Add renumber module

Browse source 
* module/language/cps/renumber.scm: New module.
* module/Makefile.am: Add to build.

fix renumber
This commit is contained in:
Andy Wingo 2014-03-30 19:09:40 +02:00
parent 98c5b69fa0
commit f05517b24e
2 changed files with 178 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

1
module/Makefile.am
View file

@ -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 \

177
module/language/cps/renumber.scm Normal file
View file

@ -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))))