(lp (1+ n) next))))))
(define (compute-new-labels-and-vars fun)
- (call-with-values (lambda ()
- (match fun
- (($ $fun free body)
- (compute-max-label-and-var body))))
+ (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)
(($ $letrec names syms funs body)
(visit-term body))
(($ $continue k src _) #f)))
- (match fun
- (($ $fun free body)
- (visit-cont body))))
+ (visit-cont fun))
(define (compute-names-in-fun fun)
(define queue '())
(($ $letrec names syms funs body)
(when reachable?
(for-each rename! syms)
- (set! queue (fold cons queue funs)))
+ (set! queue (fold (lambda (fun queue)
+ (match fun
+ (($ $fun free body)
+ (cons body queue))))
+ queue
+ funs)))
(visit-term body reachable?))
- (($ $continue k src (and fun ($ $fun)))
+ (($ $continue k src ($ $fun free body))
(when reachable?
- (set! queue (cons fun queue))))
+ (set! queue (cons body queue))))
(($ $continue) #f)))
(collect-conts fun)
(match fun
- (($ $fun free (and entry ($ $cont kfun)))
+ (($ $cont kfun)
(set! next-label (sort-conts kfun labels next-label))
- (visit-cont entry)
+ (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)
- (match fun
- (($ $fun free cont)
- (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 (visit-fun fun) nlabels nvars))))))
+ (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))))
HCoop / bpt / guile.git / blobdiff