From 3652769585f6bb8f9feb4f5c03381a567f26b7f0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 12 Jan 2014 12:37:05 +0100 Subject: [PATCH] Rename $ktrunc to $kreceive * 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. --- module/language/cps.scm | 20 ++++++------- module/language/cps/arities.scm | 6 ++-- module/language/cps/compile-bytecode.scm | 4 +-- module/language/cps/dce.scm | 8 +++--- module/language/cps/dfg.scm | 4 +-- module/language/cps/effects-analysis.scm | 4 +-- module/language/cps/elide-values.scm | 4 +-- module/language/cps/simplify.scm | 10 +++---- module/language/cps/slot-allocation.scm | 26 ++++++++--------- module/language/cps/verify.scm | 2 +- module/language/tree-il/compile-cps.scm | 36 ++++++++++++------------ 11 files changed, 62 insertions(+), 62 deletions(-) diff --git a/module/language/cps.scm b/module/language/cps.scm index 8aac42b4a..b4bcbb56f 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -53,7 +53,7 @@ ;;; ;;; 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. ;;; @@ -118,7 +118,7 @@ $cont ;; Continuation bodies. - $kif $ktrunc $kargs $kentry $ktail $kclause + $kif $kreceive $kargs $kentry $ktail $kclause ;; Expressions. $void $const $prim $fun $call $primcall $values $prompt @@ -170,7 +170,7 @@ ;; 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) @@ -199,13 +199,13 @@ (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)) @@ -303,8 +303,8 @@ (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) @@ -361,8 +361,8 @@ `(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) diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm index 052208fa6..6c589a3a1 100644 --- a/module/language/cps/arities.scm +++ b/module/language/cps/arities.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -58,7 +58,7 @@ (kvoid ($kargs () () ($continue kunspec src ($void))))) ($continue kvoid src ,exp))))) - (($ $ktrunc arity kargs) + (($ $kreceive arity kargs) ,(match arity (($ $arity () () rest () #f) (if rest @@ -99,7 +99,7 @@ ($continue k src ($primcall 'return (v)))))) ($continue k* src ,exp))))))) - (($ $ktrunc arity kargs) + (($ $kreceive arity kargs) ,(match arity (($ $arity (_) () rest () #f) (if rest diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 53ed51423..e5c6ef86b 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -204,7 +204,7 @@ (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)) @@ -313,7 +313,7 @@ (($ $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))) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index b32dea084..98c1f2c69 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -73,7 +73,7 @@ (($ $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) @@ -156,7 +156,7 @@ (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)) @@ -219,14 +219,14 @@ (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)) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm index 59e61e5d7..dd612ebd1 100644 --- a/module/language/cps/dfg.scm +++ b/module/language/cps/dfg.scm @@ -822,7 +822,7 @@ BODY for each body continuation in the prompt." (use-k! kt) (use-k! kf)) - (($ $ktrunc arity k) + (($ $kreceive arity k) (use-k! k)) (($ $letrec names syms funs body) @@ -949,7 +949,7 @@ BODY for each body continuation in the prompt." (define (find-defining-expression sym dfg) (match (find-defining-term sym dfg) (#f #f) - (($ $ktrunc) #f) + (($ $kreceive) #f) (($ $kclause) #f) (term (find-expression term)))) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 9db88b700..46c7e8884 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -466,7 +466,7 @@ (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)) diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm index 606961244..d6590aa1f 100644 --- a/module/language/cps/elide-values.scm +++ b/module/language/cps/elide-values.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -60,7 +60,7 @@ ,(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 diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm index 904ec0b23..0e3c831f5 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -89,7 +89,7 @@ (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)) @@ -135,8 +135,8 @@ (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) @@ -175,7 +175,7 @@ (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 @@ -230,7 +230,7 @@ (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 diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 5e92a6a23..946257b13 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -77,16 +77,16 @@ ;; 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. @@ -357,28 +357,28 @@ are comparable with eqv?. A tmp slot may be used." ;; 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))) @@ -486,7 +486,7 @@ are comparable with eqv?. A tmp slot may be used." (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)) @@ -571,7 +571,7 @@ are comparable with eqv?. A tmp slot may be used." (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))) @@ -639,7 +639,7 @@ are comparable with eqv?. A tmp slot may be used." (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) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index 94c111e36..9da5037ba 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -59,7 +59,7 @@ (($ $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)) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 1960023dd..6e987a3f3 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -178,7 +178,7 @@ ($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 @@ -189,9 +189,9 @@ ($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 @@ -209,11 +209,11 @@ ((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 @@ -429,12 +429,12 @@ (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 () () @@ -447,7 +447,7 @@ ($prim 'values)))))) ($continue kret src ($primcall 'unwind ()))))) - (krest ($ktrunc '() 'rest kpop))) + (krest ($kreceive '() 'rest kpop))) ,(if escape-only? (build-cps-term ($letk ((kbody ($kargs () () @@ -539,25 +539,25 @@ ($continue k src ($primcall 'box-set! (box exp))))))))) (($ 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))))) (($ 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)))))))) (($ src names gensyms funs body) ;; Some letrecs can be contified; that happens later. @@ -582,14 +582,14 @@ (($ src exp ($ 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 -- 2.20.1