* module/language/cps.scm ($kreceive): Rename from ktrunc.
* module/language/cps/arities.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/dce.scm:
* module/language/cps/dfg.scm:
* module/language/cps/effects-analysis.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/verify.scm:
* module/language/tree-il/compile-cps.scm: Adapt all users.
;;;
;;; There are some Guile-specific quirks as well:
;;;
-;;; - $ktrunc represents a continuation that receives multiple values,
+;;; - $kreceive represents a continuation that receives multiple values,
;;; but which truncates them to some number of required values,
;;; possibly with a rest list.
;;;
$cont
;; Continuation bodies.
- $kif $ktrunc $kargs $kentry $ktail $kclause
+ $kif $kreceive $kargs $kentry $ktail $kclause
;; Expressions.
$void $const $prim $fun $call $primcall $values $prompt
;; Continuations
(define-cps-type $cont k cont)
(define-cps-type $kif kt kf)
-(define-cps-type $ktrunc arity k)
+(define-cps-type $kreceive arity k)
(define-cps-type $kargs names syms body)
(define-cps-type $kentry self tail clauses)
(define-cps-type $ktail)
(make-$arity req opt rest kw allow-other-keys?))))
(define-syntax build-cont-body
- (syntax-rules (unquote $kif $ktrunc $kargs $kentry $ktail $kclause)
+ (syntax-rules (unquote $kif $kreceive $kargs $kentry $ktail $kclause)
((_ (unquote exp))
exp)
((_ ($kif kt kf))
(make-$kif kt kf))
- ((_ ($ktrunc req rest kargs))
- (make-$ktrunc (make-$arity req '() rest '() #f) kargs))
+ ((_ ($kreceive req rest kargs))
+ (make-$kreceive (make-$arity req '() rest '() #f) kargs))
((_ ($kargs (name ...) (sym ...) body))
(make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
((_ ($kargs names syms body))
(sym ,(parse-cps body))))
(('kif kt kf)
(build-cont-body ($kif kt kf)))
- (('ktrunc req rest k)
- (build-cont-body ($ktrunc req rest k)))
+ (('kreceive req rest k)
+ (build-cont-body ($kreceive req rest k)))
(('kargs names syms body)
(build-cont-body ($kargs names syms ,(parse-cps body))))
(('kentry self tail clauses)
`(k ,sym ,(unparse-cps body)))
(($ $kif kt kf)
`(kif ,kt ,kf))
- (($ $ktrunc ($ $arity req () rest '() #f) k)
- `(ktrunc ,req ,rest ,k))
+ (($ $kreceive ($ $arity req () rest '() #f) k)
+ `(kreceive ,req ,rest ,k))
(($ $kargs () () body)
`(kseq ,(unparse-cps body)))
(($ $kargs names syms body)
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 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
(kvoid ($kargs () ()
($continue kunspec src ($void)))))
($continue kvoid src ,exp)))))
- (($ $ktrunc arity kargs)
+ (($ $kreceive arity kargs)
,(match arity
(($ $arity () () rest () #f)
(if rest
($continue k src
($primcall 'return (v))))))
($continue k* src ,exp)))))))
- (($ $ktrunc arity kargs)
+ (($ $kreceive arity kargs)
,(match arity
(($ $arity (_) () rest () #f)
(if rest
(and (= k-idx (1+ n))
(< (+ n 2) (cfa-k-count cfa))
(cfa-k-sym cfa (+ n 2)))))
- (($ $ktrunc ($ $arity req () rest () #f) kargs)
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
(compile-trunc label k exp (length req)
(and rest
(match (vector-ref contv (cfa-k-idx cfa kargs))
(($ $values ()) #f)
(($ $prompt escape? tag handler)
(match (lookup-cont handler)
- (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
+ (($ $kreceive ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler"))
(nreq (length req))
(proc-slot (lookup-call-proc-slot handler allocation)))
(($ $kargs _ _ body)
(match (find-call body)
(($ $continue k) (cont-defs k))))
- (($ $ktrunc arity kargs)
+ (($ $kreceive arity kargs)
(cont-defs kargs))
(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
syms)
(when (value-live? def)
(mark-live! use)))
args defs))))))))))
- (($ $ktrunc arity kargs) #f)
+ (($ $kreceive arity kargs) #f)
(($ $kif) #f)
(($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
(for-each mark-live! syms))
(build-cps-cont
(sym ($kclause ,arity
,(must-visit-cont body))))))
- (($ $ktrunc ($ $arity req () rest () #f) kargs)
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
(let ((defs (vector-ref defs n)))
(if (and-map value-live? defs)
(list (build-cps-cont (sym ,cont)))
(let-gensyms (adapt)
(list (make-adaptor adapt kargs defs)
(build-cps-cont
- (sym ($ktrunc req rest adapt))))))))
+ (sym ($kreceive req rest adapt))))))))
(_ (list (build-cps-cont (sym ,cont))))))))))
(define (visit-conts conts)
(append-map visit-cont conts))
(use-k! kt)
(use-k! kf))
- (($ $ktrunc arity k)
+ (($ $kreceive arity k)
(use-k! k))
(($ $letrec names syms funs body)
(define (find-defining-expression sym dfg)
(match (find-defining-term sym dfg)
(#f #f)
- (($ $ktrunc) #f)
+ (($ $kreceive) #f)
(($ $kclause) #f)
(term (find-expression term))))
;;; Effects analysis on CPS
-;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013, 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
(match (lookup-cont (cfa-k-sym cfa n) (dfg-cont-table dfg))
(($ $kargs names syms body)
(expression-effects (find-expression body) dfg))
- (($ $ktrunc arity kargs)
+ (($ $kreceive arity kargs)
(match arity
(($ $arity _ () #f () #f) (cause &type-check))
(($ $arity () () _ () #f) (cause &allocation))
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 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
,(rewrite-cps-term (lookup-cont k conts)
(($ $ktail)
($continue k src ($values vals)))
- (($ $ktrunc ($ $arity req () rest () #f) kargs)
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
,(cond
((and (not rest) (= (length vals) (length req)))
(build-cps-term
(sym ($kentry self ,tail ,(visit-conts clauses))))
(($ $kclause arity body)
(sym ($kclause ,arity ,(must-visit-cont body))))
- ((or ($ $ktrunc) ($ $kif))
+ ((or ($ $kreceive) ($ $kif))
(sym ,cont)))))))
(define (visit-conts conts)
(filter-map visit-cont conts))
(sym ($kentry self ,tail ,(map (cut visit-cont <> sym) clauses))))
(($ $cont sym ($ $kclause arity body))
(sym ($kclause ,arity ,(visit-cont body sym))))
- (($ $cont sym ($ $ktrunc ($ $arity req () rest () #f) kargs))
- (sym ($ktrunc req rest (reduce kargs scope))))
+ (($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
+ (sym ($kreceive req rest (reduce kargs scope))))
(($ $cont sym ($ $kif kt kf))
(sym ($kif (reduce kt scope) (reduce kf scope))))))
(define (visit-term term scope)
(for-each visit-cont clauses))
(($ $cont sym ($ $kclause arity body))
(visit-cont body))
- (($ $cont sym (or ($ $ktail) ($ $ktrunc) ($ $kif)))
+ (($ $cont sym (or ($ $ktail) ($ $kreceive) ($ $kif)))
#f)))
(define (visit-term term)
(match term
(sym ($kentry self ,tail ,(map must-visit-cont clauses))))
(($ $kclause arity body)
(sym ($kclause ,arity ,(must-visit-cont body))))
- ((or ($ $ktrunc) ($ $kif))
+ ((or ($ $kreceive) ($ $kif))
(sym ,cont)))))))
(define (visit-term term)
(match term
;; are called "call moves", and moves to handle a return are "return
;; moves".
;;
- ;; $ktrunc continuations record a proc slot and a set of return moves
+ ;; $kreceive continuations record a proc slot and a set of return moves
;; to adapt multiple values from the stack to local variables.
;;
;; Tail calls record arg moves, but no proc slot.
;;
;; Non-tail calls record arg moves and a call slot. Multiple-valued
- ;; returns will have an associated $ktrunc continuation, which records
+ ;; returns will have an associated $kreceive continuation, which records
;; the same proc slot, but has return moves.
;;
- ;; $prompt handlers are $ktrunc continuations like any other.
+ ;; $prompt handlers are $kreceive continuations like any other.
;;
;; $values expressions with more than 1 value record moves but have no
;; proc slot.
;; Results of function calls that are not used don't need to be
;; allocated to slots.
(define (compute-unused-results!)
- (define (ktrunc-get-kargs n)
+ (define (kreceive-get-kargs n)
(match (vector-ref contv n)
- (($ $ktrunc arity kargs) (cfa-k-idx cfa kargs))
+ (($ $kreceive arity kargs) (cfa-k-idx cfa kargs))
(_ #f)))
(let ((candidates (make-bitvector (vector-length contv) #f)))
- ;; Find all $kargs that are the successors of $ktrunc nodes.
+ ;; Find all $kargs that are the successors of $kreceive nodes.
(let lp ((n 0))
(when (< n (vector-length contv))
- (and=> (ktrunc-get-kargs n)
+ (and=> (kreceive-get-kargs n)
(lambda (kargs)
(bitvector-set! candidates kargs #t)))
(lp (1+ n))))
- ;; For $kargs that only have $ktrunc predecessors, remove unused
+ ;; For $kargs that only have $kreceive predecessors, remove unused
;; variables from the needs-slotv set.
(let lp ((n 0))
(let ((n (bit-position #t candidates n)))
(when n
(match (cfa-predecessors cfa n)
- ;; At least one ktrunc is in the predecessor set, so we
+ ;; At least one kreceive is in the predecessor set, so we
;; only need to do the check for nodes with >1
;; predecessor.
- ((or (_) ((? ktrunc-get-kargs) ...))
+ ((or (_) ((? kreceive-get-kargs) ...))
(for-each (lambda (var)
(when (dead-after-def? (cfa-k-sym cfa n) var dfa)
(bitvector-set! needs-slotv var #f)))
(bump-nlocals! tail-nlocals)
(hashq-set! call-allocations label
(make-call-allocation #f moves))))
- (($ $ktrunc arity kargs)
+ (($ $kreceive arity kargs)
(let* ((proc-slot (compute-call-proc-slot post-live))
(call-slots (map (cut + proc-slot <>) (iota (length uses))))
(pre-live (fold allocate! pre-live uses call-slots))
(define (allocate-prompt label k handler nargs)
(match (vector-ref contv (cfa-k-idx cfa handler))
- (($ $ktrunc arity kargs)
+ (($ $kreceive arity kargs)
(let* ((handler-live (recompute-live-slots handler nargs))
(proc-slot (compute-prompt-handler-proc-slot handler-live))
(result-vars (vector-ref defv (cfa-k-idx cfa kargs)))
(allocate-prompt label k handler nargs))
(_ #f)))
(lp (1+ n) post-live))
- ((or ($ $ktrunc) ($ $kif) ($ $ktail))
+ ((or ($ $kreceive) ($ $kif) ($ $ktail))
(lp (1+ n) post-live)))))))
(define (visit-entry)
(($ $kif kt kf)
(check-var kt k-env)
(check-var kf k-env))
- (($ $ktrunc ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
+ (($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
(check-var k k-env))
(($ $kargs ((? symbol? name) ...) ((? symbol? sym) ...) body)
(unless (= (length name) (length sym))
($continue k src ($primcall 'box (phi))))))
,(make-body kbox))))
(make-body k)))
- (let-gensyms (knext kbound kunbound ktrunc krest val rest)
+ (let-gensyms (knext kbound kunbound kreceive krest val rest)
(build-cps-term
($letk ((knext ($kargs (name) (subst-sym) ,body)))
,(maybe-box
($values (sym)))))
(krest ($kargs (name 'rest) (val rest)
($continue k src ($values (val)))))
- (ktrunc ($ktrunc (list name) 'rest krest))
+ (kreceive ($kreceive (list name) 'rest krest))
(kunbound ($kargs () ()
- ,(convert init ktrunc subst))))
+ ,(convert init kreceive subst))))
,(unbound? src sym kunbound kbound))))))))))))
;; exp k-name alist -> term
((subst #f) (k subst))
(#f (k sym))))
(else
- (let-gensyms (ktrunc karg arg rest)
+ (let-gensyms (kreceive karg arg rest)
(build-cps-term
($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
- (ktrunc ($ktrunc '(arg) 'rest karg)))
- ,(convert exp ktrunc subst)))))))
+ (kreceive ($kreceive '(arg) 'rest karg)))
+ ,(convert exp kreceive subst)))))))
;; (exp ...) ((v-name ...) -> term) -> term
(define (convert-args exps k)
(match exps
(let ((hnames (append hreq (if hrest (list hrest) '()))))
(let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
(build-cps-term
- ;; FIXME: Attach hsrc to $ktrunc.
+ ;; FIXME: Attach hsrc to $kreceive.
($letk* ((khbody ($kargs hnames hsyms
,(fold box-bound-var
(convert hbody k subst)
hnames hsyms)))
- (khargs ($ktrunc hreq hrest khbody))
+ (khargs ($kreceive hreq hrest khbody))
(kpop ($kargs ('rest) (vals)
($letk ((kret
($kargs () ()
($prim 'values))))))
($continue kret src
($primcall 'unwind ())))))
- (krest ($ktrunc '() 'rest kpop)))
+ (krest ($kreceive '() 'rest kpop)))
,(if escape-only?
(build-cps-term
($letk ((kbody ($kargs () ()
($continue k src ($primcall 'box-set! (box exp)))))))))
(($ <seq> src head tail)
- (let-gensyms (ktrunc kseq vals)
+ (let-gensyms (kreceive kseq vals)
(build-cps-term
($letk* ((kseq ($kargs ('vals) (vals)
,(convert tail k subst)))
- (ktrunc ($ktrunc '() 'vals kseq)))
- ,(convert head ktrunc subst)))))
+ (kreceive ($kreceive '() 'vals kseq)))
+ ,(convert head kreceive subst)))))
(($ <let> src names syms vals body)
(let lp ((names names) (syms syms) (vals vals))
(match (list names syms vals)
((() () ()) (convert body k subst))
(((name . names) (sym . syms) (val . vals))
- (let-gensyms (ktrunc klet rest)
+ (let-gensyms (kreceive klet rest)
(build-cps-term
($letk* ((klet ($kargs (name 'rest) (sym rest)
,(box-bound-var name sym
(lp names syms vals))))
- (ktrunc ($ktrunc (list name) 'rest klet)))
- ,(convert val ktrunc subst))))))))
+ (kreceive ($kreceive (list name) 'rest klet)))
+ ,(convert val kreceive subst))))))))
(($ <fix> src names gensyms funs body)
;; Some letrecs can be contified; that happens later.
(($ <let-values> src exp
($ <lambda-case> lsrc req #f rest #f () syms body #f))
(let ((names (append req (if rest (list rest) '()))))
- (let-gensyms (ktrunc kargs)
+ (let-gensyms (kreceive kargs)
(build-cps-term
($letk* ((kargs ($kargs names syms
,(fold box-bound-var
(convert body k subst)
names syms)))
- (ktrunc ($ktrunc req rest kargs)))
- ,(convert exp ktrunc subst))))))))
+ (kreceive ($kreceive req rest kargs)))
+ ,(convert exp kreceive subst))))))))
(define (build-subst exp)
"Compute a mapping from lexical gensyms to substituted gensyms. The
HCoop / bpt / guile.git / commitdiff