[bpt/guile.git] / module / language / cps / renumber.scm

;;; 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 and, in the case of labels,
;;; topologically sorted.
;;;
;;; Code:

(define-module (language cps renumber)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (language cps)
  #:export (renumber))

;; Topologically sort the continuation tree starting at k0, using
;; reverse post-order numbering.
(define (sort-conts k0 conts new-k0)
  (define (for-each-successor f cont)
    (visit-cont-successors
     (case-lambda
       (() #t)
       ((succ0) (f succ0))
       ((succ0 succ1)
        ;; Visit higher-numbered successors first, so that if they are
        ;; unordered, their original order is preserved.
        (cond
         ((< succ0 succ1) (f succ1) (f succ0))
         (else (f succ0) (f succ1)))))
     cont))

  (let ((next -1))
    (let visit ((k k0))
      (let ((cont (vector-ref conts k)))
        ;; Clear the cont table entry to mark this continuation as
        ;; visited.
        (vector-set! conts k #f)
        (for-each-successor (lambda (k)
                              (let ((entry (vector-ref conts k)))
                                ;; Visit the successor if it has not been
                                ;; visited yet.
                                (when (and entry (not (exact-integer? entry)))
                                  (visit k))))
                            cont)
        ;; Chain this label to the label that will follow it in the sort
        ;; order, and record this label as the new head of the order.
        (vector-set! conts k next)
        (set! next k)))

    ;; Finally traverse the label chain, giving each label its final
    ;; name.
    (let lp ((n new-k0) (head next))
      (if (< head 0)
          n
          (let ((next (vector-ref conts head)))
            (vector-set! conts head n)
            (lp (1+ n) next))))))

(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) #f))
            (next-label 0)
            (vars (make-vector (1+ max-var) #f))
            (next-var 0))
        (define (rename! var)
          (vector-set! vars var next-var)
          (set! next-var (1+ next-var)))

        (define (collect-conts fun)
          (define (visit-cont cont)
            (match cont
              (($ $cont label cont)
               (vector-set! labels label cont)
               (match cont
                 (($ $kargs names vars body)
                  (visit-term body))
                 (($ $kfun src meta self tail clause)
                  (visit-cont tail)
                  (when clause
                    (visit-cont clause)))
                 (($ $kclause arity body alternate)
                  (visit-cont body)
                  (when alternate
                    (visit-cont alternate)))
                 ((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)
               (visit-term body))
              (($ $continue k src _) #f)))
          (visit-cont fun))

        (define (compute-names-in-fun fun)
          (define queue '())
          (define (visit-cont cont)
            (match cont
              (($ $cont label cont)
               (let ((reachable? (exact-integer? (vector-ref labels label))))
                 ;; This cont is reachable if it was given a number.
                 ;; Otherwise the cont table entry still contains the
                 ;; cont itself; clear it out to indicate that the cont
                 ;; should not be residualized.
                 (unless reachable?
                   (vector-set! labels label #f))
                 (match cont
                   (($ $kargs names vars body)
                    (when reachable?
                      (for-each rename! vars))
                    (visit-term body reachable?))
                   (($ $kfun src meta self tail clause)
                    (unless reachable? (error "entry should be reachable"))
                    (rename! self)
                    (visit-cont tail)
                    (when clause
                      (visit-cont clause)))
                   (($ $kclause arity body alternate)
                    (unless reachable? (error "clause should be reachable"))
                    (visit-cont body)
                    (when alternate
                      (visit-cont alternate)))
                   (($ $ktail)
                    (unless reachable?
                      ;; It's possible for the tail to be unreachable,
                      ;; if all paths contify to infinite loops.  Make
                      ;; sure we mark as reachable.
                      (vector-set! labels label next-label)
                      (set! next-label (1+ next-label))))
                   ((or ($ $kreceive) ($ $kif))
                    #f))))))
          (define (visit-term term reachable?)
            (match term
              (($ $letk conts body)
               (for-each visit-cont conts)
               (visit-term body reachable?))
              (($ $letrec names syms funs body)
               (when reachable?
                 (for-each rename! syms)
                 (set! queue (fold (lambda (fun queue)
                                     (match fun
                                       (($ $fun free body)
                                        (cons body queue))))
                                   queue
                                   funs)))
               (visit-term body reachable?))
              (($ $continue k src ($ $fun free body))
               (when reachable?
                 (set! queue (cons body queue))))
              (($ $continue) #f)))

          (collect-conts fun)
          (match fun
            (($ $cont kfun)
             (set! next-label (sort-conts kfun labels next-label))
             (visit-cont fun)
             (for-each compute-names-in-fun (reverse queue)))))

        (compute-names-in-fun fun)
        (values labels vars next-label next-var)))))

(define (renumber fun)
  (call-with-values (lambda () (compute-new-labels-and-vars fun))
    (lambda (labels vars nlabels nvars)
      (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 (must-visit-cont cont)
        (or (visit-cont cont)
            (error "internal error -- failed to visit cont")))
      (define (visit-conts conts)
        (match conts
          (() '())
          ((cont . conts)
           (cond
            ((visit-cont cont)
             => (lambda (cont)
                  (cons cont (visit-conts conts))))
            (else (visit-conts conts))))))
      (define (visit-cont cont)
        (match cont
          (($ $cont label cont)
           (let ((label (relabel label)))
             (and
              label
              (rewrite-cps-cont cont
                (($ $kargs names vars body)
                 (label ($kargs names (map rename vars) ,(visit-term body))))
                (($ $kfun src meta self tail clause)
                 (label
                  ($kfun src meta (rename self) ,(must-visit-cont tail)
                    ,(and clause (must-visit-cont clause)))))
                (($ $ktail)
                 (label ($ktail)))
                (($ $kclause arity body alternate)
                 (label
                  ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
                            ,(and alternate (must-visit-cont alternate)))))
                (($ $kreceive ($ $arity req () rest () #f) kargs)
                 (label ($kreceive req rest (relabel kargs))))
                (($ $kif kt kf)
                 (label ($kif (relabel kt) (relabel kf))))))))))
      (define (visit-term term)
        (rewrite-cps-term term
          (($ $letk conts body)
           ,(match (visit-conts conts)
              (() (visit-term body))
              (conts (build-cps-term ($letk ,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 free body)
           ($fun (map rename free) ,(must-visit-cont body)))))
      (values (must-visit-cont fun) nlabels nvars))))
Commit	Line	Data
f05517b2 AW	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
09220d21 AW	22	;;; are contiguous within each function and, in the case of labels,
09220d21 AW	23	;;; topologically sorted.
f05517b2 AW	24	;;;
	25	;;; Code:
	26
	27	(define-module (language cps renumber)
	28	#:use-module (ice-9 match)
f9bceb77	29	#:use-module (srfi srfi-1)
f05517b2 AW	30	#:use-module (language cps)
	31	#:export (renumber))
	32
09220d21 AW	33	;; Topologically sort the continuation tree starting at k0, using
	34	;; reverse post-order numbering.
	35	(define (sort-conts k0 conts new-k0)
	36	(define (for-each-successor f cont)
	37	(visit-cont-successors
	38	(case-lambda
	39	(() #t)
	40	((succ0) (f succ0))
	41	((succ0 succ1)
	42	;; Visit higher-numbered successors first, so that if they are
	43	;; unordered, their original order is preserved.
	44	(cond
	45	((< succ0 succ1) (f succ1) (f succ0))
	46	(else (f succ0) (f succ1)))))
	47	cont))
	48
	49	(let ((next -1))
	50	(let visit ((k k0))
	51	(let ((cont (vector-ref conts k)))
	52	;; Clear the cont table entry to mark this continuation as
	53	;; visited.
	54	(vector-set! conts k #f)
	55	(for-each-successor (lambda (k)
	56	(let ((entry (vector-ref conts k)))
	57	;; Visit the successor if it has not been
	58	;; visited yet.
	59	(when (and entry (not (exact-integer? entry)))
	60	(visit k))))
	61	cont)
	62	;; Chain this label to the label that will follow it in the sort
	63	;; order, and record this label as the new head of the order.
	64	(vector-set! conts k next)
	65	(set! next k)))
	66
	67	;; Finally traverse the label chain, giving each label its final
	68	;; name.
	69	(let lp ((n new-k0) (head next))
	70	(if (< head 0)
	71	n
	72	(let ((next (vector-ref conts head)))
	73	(vector-set! conts head n)
	74	(lp (1+ n) next))))))
	75
f05517b2	76	(define (compute-new-labels-and-vars fun)
a0329d01	77	(call-with-values (lambda () (compute-max-label-and-var fun))
f05517b2	78	(lambda (max-label max-var)
09220d21	79	(let ((labels (make-vector (1+ max-label) #f))
f05517b2	80	(next-label 0)
09220d21	81	(vars (make-vector (1+ max-var) #f))
f05517b2	82	(next-var 0))
f05517b2 AW	83	(define (rename! var)
	84	(vector-set! vars var next-var)
	85	(set! next-var (1+ next-var)))
09220d21 AW	86
09220d21 AW	87	(define (collect-conts fun)
f05517b2 AW	88	(define (visit-cont cont)
	89	(match cont
	90	(($ $cont label cont)
09220d21	91	(vector-set! labels label cont)
f05517b2 AW	92	(match cont
f05517b2 AW	93	(($ $kargs names vars body)
f05517b2	94	(visit-term body))
8320f504	95	(($ $kfun src meta self tail clause)
f05517b2	96	(visit-cont tail)
90dce16d AW	97	(when clause
	98	(visit-cont clause)))
	99	(($ $kclause arity body alternate)
	100	(visit-cont body)
	101	(when alternate
	102	(visit-cont alternate)))
f05517b2 AW	103	((or ($ $ktail) ($ $kreceive) ($ $kif))
	104	#f)))))
	105	(define (visit-term term)
	106	(match term
	107	(($ $letk conts body)
	108	(for-each visit-cont conts)
	109	(visit-term body))
	110	(($ $letrec names syms funs body)
f05517b2	111	(visit-term body))
09220d21	112	(($ $continue k src _) #f)))
a0329d01	113	(visit-cont fun))
f05517b2	114
09220d21	115	(define (compute-names-in-fun fun)
f9bceb77	116	(define queue '())
09220d21 AW	117	(define (visit-cont cont)
	118	(match cont
	119	(($ $cont label cont)
	120	(let ((reachable? (exact-integer? (vector-ref labels label))))
	121	;; This cont is reachable if it was given a number.
	122	;; Otherwise the cont table entry still contains the
	123	;; cont itself; clear it out to indicate that the cont
	124	;; should not be residualized.
	125	(unless reachable?
	126	(vector-set! labels label #f))
	127	(match cont
	128	(($ $kargs names vars body)
	129	(when reachable?
	130	(for-each rename! vars))
	131	(visit-term body reachable?))
8320f504	132	(($ $kfun src meta self tail clause)
f9bceb77 AW	133	(unless reachable? (error "entry should be reachable"))
f9bceb77 AW	134	(rename! self)
09220d21 AW	135	(visit-cont tail)
	136	(when clause
	137	(visit-cont clause)))
	138	(($ $kclause arity body alternate)
f9bceb77	139	(unless reachable? (error "clause should be reachable"))
09220d21 AW	140	(visit-cont body)
	141	(when alternate
	142	(visit-cont alternate)))
	143	(($ $ktail)
	144	(unless reachable?
	145	;; It's possible for the tail to be unreachable,
	146	;; if all paths contify to infinite loops. Make
	147	;; sure we mark as reachable.
	148	(vector-set! labels label next-label)
	149	(set! next-label (1+ next-label))))
f9bceb77	150	((or ($ $kreceive) ($ $kif))
09220d21 AW	151	#f))))))
	152	(define (visit-term term reachable?)
	153	(match term
	154	(($ $letk conts body)
	155	(for-each visit-cont conts)
	156	(visit-term body reachable?))
	157	(($ $letrec names syms funs body)
	158	(when reachable?
f9bceb77	159	(for-each rename! syms)
a0329d01 AW	160	(set! queue (fold (lambda (fun queue)
	161	(match fun
	162	(($ $fun free body)
	163	(cons body queue))))
	164	queue
	165	funs)))
09220d21	166	(visit-term body reachable?))
a0329d01	167	(($ $continue k src ($ $fun free body))
f9bceb77	168	(when reachable?
a0329d01	169	(set! queue (cons body queue))))
f9bceb77	170	(($ $continue) #f)))
09220d21 AW	171
	172	(collect-conts fun)
	173	(match fun
a0329d01	174	(($ $cont kfun)
8320f504	175	(set! next-label (sort-conts kfun labels next-label))
a0329d01	176	(visit-cont fun)
f9bceb77	177	(for-each compute-names-in-fun (reverse queue)))))
09220d21	178
f9bceb77	179	(compute-names-in-fun fun)
cc8eb195	180	(values labels vars next-label next-var)))))
f05517b2 AW	181
f05517b2 AW	182	(define (renumber fun)
a0329d01 AW	183	(call-with-values (lambda () (compute-new-labels-and-vars fun))
	184	(lambda (labels vars nlabels nvars)
	185	(define (relabel label) (vector-ref labels label))
	186	(define (rename var) (vector-ref vars var))
	187	(define (rename-kw-arity arity)
	188	(match arity
	189	(($ $arity req opt rest kw aok?)
	190	(make-$arity req opt rest
	191	(map (match-lambda
	192	((kw kw-name kw-var)
	193	(list kw kw-name (rename kw-var))))
	194	kw)
	195	aok?))))
	196	(define (must-visit-cont cont)
	197	(or (visit-cont cont)
	198	(error "internal error -- failed to visit cont")))
	199	(define (visit-conts conts)
	200	(match conts
	201	(() '())
	202	((cont . conts)
	203	(cond
	204	((visit-cont cont)
	205	=> (lambda (cont)
	206	(cons cont (visit-conts conts))))
	207	(else (visit-conts conts))))))
	208	(define (visit-cont cont)
	209	(match cont
	210	(($ $cont label cont)
	211	(let ((label (relabel label)))
	212	(and
	213	label
	214	(rewrite-cps-cont cont
	215	(($ $kargs names vars body)
	216	(label ($kargs names (map rename vars) ,(visit-term body))))
	217	(($ $kfun src meta self tail clause)
	218	(label
	219	($kfun src meta (rename self) ,(must-visit-cont tail)
	220	,(and clause (must-visit-cont clause)))))
	221	(($ $ktail)
	222	(label ($ktail)))
	223	(($ $kclause arity body alternate)
	224	(label
	225	($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
	226	,(and alternate (must-visit-cont alternate)))))
	227	(($ $kreceive ($ $arity req () rest () #f) kargs)
	228	(label ($kreceive req rest (relabel kargs))))
	229	(($ $kif kt kf)
	230	(label ($kif (relabel kt) (relabel kf))))))))))
	231	(define (visit-term term)
	232	(rewrite-cps-term term
	233	(($ $letk conts body)
	234	,(match (visit-conts conts)
	235	(() (visit-term body))
	236	(conts (build-cps-term ($letk ,conts ,(visit-term body))))))
	237	(($ $letrec names vars funs body)
	238	($letrec names (map rename vars) (map visit-fun funs)
	239	,(visit-term body)))
	240	(($ $continue k src exp)
	241	($continue (relabel k) src ,(visit-exp exp)))))
	242	(define (visit-exp exp)
	243	(match exp
	244	((or ($ $void) ($ $const) ($ $prim))
	245	exp)
	246	(($ $fun)
247	(visit-fun exp))
248	(($ $values args)
249	(let ((args (map rename args)))
250	(build-cps-exp ($values args))))
251	(($ $call proc args)
252	(let ((args (map rename args)))
253	(build-cps-exp ($call (rename proc) args))))
254	(($ $callk k proc args)
255	(let ((args (map rename args)))
256	(build-cps-exp ($callk (relabel k) (rename proc) args))))
257	(($ $primcall name args)
258	(let ((args (map rename args)))
259	(build-cps-exp ($primcall name args))))
260	(($ $prompt escape? tag handler)
261	(build-cps-exp
262	($prompt escape? (rename tag) (relabel handler))))))
263	(define (visit-fun fun)
264	(rewrite-cps-exp fun
265	(($ $fun free body)
266	($fun (map rename free) ,(must-visit-cont body)))))
267	(values (must-visit-cont fun) nlabels nvars))))