mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +02:00
Code Activity

Remove $kif

Browse source 
* module/language/cps.scm: Remove $kif.

* module/language/cps/compile-bytecode.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/dfg.scm:
* module/language/cps/effects-analysis.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/renumber.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/type-fold.scm:
* module/language/cps/types.scm:
* module/language/cps/verify.scm: Adapt.
This commit is contained in:
Andy Wingo 2014-05-31 21:43:12 -04:00
parent fd61004764
commit 59258f7cad
13 changed files with 36 additions and 135 deletions
Download patch file Download diff file Expand all files Collapse all files

19
module/language/cps.scm
View file

@ -27,8 +27,8 @@
;;; $letk binds a set of mutually recursive continuations, each one an ;;; $letk binds a set of mutually recursive continuations, each one an
;;; instance of $cont. A $cont declares the name of a continuation, and ;;; instance of $cont. A $cont declares the name of a continuation, and
;;; then contains as a subterm the particular continuation instance: ;;; then contains as a subterm the particular continuation instance:
;;; $kif for test continuations, $kargs for continuations that bind ;;; $kargs for continuations that bind values, $ktail for the tail
;;; values, etc. ;;; continuation, etc.
;;; ;;;
;;; $continue nodes call continuations. The expression contained in the ;;; $continue nodes call continuations. The expression contained in the
;;; $continue node determines the value or values that are passed to the ;;; $continue node determines the value or values that are passed to the
@ -92,7 +92,7 @@
;;; - $letk, $letrec, and $continue are terms. ;;; - $letk, $letrec, and $continue are terms.
;;; ;;;
;;; - $cont is a continuation, containing a continuation body ($kargs, ;;; - $cont is a continuation, containing a continuation body ($kargs,
;;; $kif, etc). ;;; $ktail, etc).
;;; ;;;
;;; - $continue terms contain an expression ($call, $const, $fun, ;;; - $continue terms contain an expression ($call, $const, $fun,
;;; etc). ;;; etc).
@ -119,7 +119,7 @@
$cont $cont
;; Continuation bodies. ;; Continuation bodies.
$kif $kreceive $kargs $kfun $ktail $kclause $kreceive $kargs $kfun $ktail $kclause
;; Expressions. ;; Expressions.
$void $const $prim $fun $closure $branch $void $const $prim $fun $closure $branch
@ -181,7 +181,6 @@
;; Continuations ;; Continuations
(define-cps-type $cont k cont) (define-cps-type $cont k cont)
(define-cps-type $kif kt kf)
(define-cps-type $kreceive arity k) (define-cps-type $kreceive arity k)
(define-cps-type $kargs names syms body) (define-cps-type $kargs names syms body)
(define-cps-type $kfun src meta self tail clause) (define-cps-type $kfun src meta self tail clause)
@ -239,11 +238,9 @@
(make-$arity req opt rest kw allow-other-keys?)))) (make-$arity req opt rest kw allow-other-keys?))))
(define-syntax build-cont-body (define-syntax build-cont-body
(syntax-rules (unquote $kif $kreceive $kargs $kfun $ktail $kclause) (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
((_ (unquote exp)) ((_ (unquote exp))
exp) exp)
((_ ($kif kt kf))
(make-$kif kt kf))
((_ ($kreceive req rest kargs)) ((_ ($kreceive req rest kargs))
(make-$kreceive (make-$arity req '() rest '() #f) kargs)) (make-$kreceive (make-$arity req '() rest '() #f) kargs))
((_ ($kargs (name ...) (unquote syms) body)) ((_ ($kargs (name ...) (unquote syms) body))
@ -356,8 +353,6 @@
(('k sym body) (('k sym body)
(build-cps-cont (build-cps-cont
(sym ,(parse-cps body)))) (sym ,(parse-cps body))))
(('kif kt kf)
(build-cont-body ($kif kt kf)))
(('kreceive req rest k) (('kreceive req rest k)
(build-cont-body ($kreceive req rest k))) (build-cont-body ($kreceive req rest k)))
(('kargs names syms body) (('kargs names syms body)
@ -429,8 +424,6 @@
`(letk ,(map unparse-cps conts) ,(unparse-cps body))) `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
(($ $cont sym body) (($ $cont sym body)
`(k ,sym ,(unparse-cps body))) `(k ,sym ,(unparse-cps body)))
(($ $kif kt kf)
`(kif ,kt ,kf))
(($ $kreceive ($ $arity req () rest '() #f) k) (($ $kreceive ($ $arity req () rest '() #f) k)
`(kreceive ,req ,rest ,k)) `(kreceive ,req ,rest ,k))
(($ $kargs () () body) (($ $kargs () () body)
@ -632,8 +625,6 @@
(($ $branch kt) (proc k kt)) (($ $branch kt) (proc k kt))
(_ (proc k))))))) (_ (proc k)))))))
(($ $kif kt kf) (proc kt kf))
(($ $kreceive arity k) (proc k)) (($ $kreceive arity k) (proc k))
(($ $kclause arity ($ $cont kbody) #f) (proc kbody)) (($ $kclause arity ($ $cont kbody) #f) (proc kbody))

2
module/language/cps/compile-bytecode.scm
View file

@ -198,8 +198,6 @@
(($ $kargs names syms) (($ $kargs names syms)
(compile-values label exp syms) (compile-values label exp syms)
(maybe-emit-jump)) (maybe-emit-jump))
(($ $kif kt kf)
(compile-test label exp kt kf (and fallthrough? (1+ k))))
(($ $kreceive ($ $arity req () rest () #f) kargs) (($ $kreceive ($ $arity req () rest () #f) kargs)
(compile-trunc label k exp (length req) (compile-trunc label k exp (length req)
(and rest (and rest

31
module/language/cps/cse.scm
View file

@ -177,16 +177,15 @@ be that both true and false proofs are available."
(if initialized? (if initialized?
(intersect! bool (vector-ref boolv pidx)) (intersect! bool (vector-ref boolv pidx))
(bitvector-copy! bool (vector-ref boolv pidx))) (bitvector-copy! bool (vector-ref boolv pidx)))
(match (lookup-predecessors pred dfg) (match (lookup-cont pred dfg)
((test) (($ $kargs _ _ term)
(let ((tidx (label->idx test))) (match (find-call term)
(match (lookup-cont pred dfg) (($ $continue kf ($ $branch kt exp))
(($ $kif kt kf) (when (eqv? kt label)
(when (eqv? kt label) (bitvector-set! bool (true-idx pidx) #t))
(bitvector-set! bool (true-idx tidx) #t)) (when (eqv? kf label)
(when (eqv? kf label) (bitvector-set! bool (false-idx pidx) #t)))
(bitvector-set! bool (false-idx tidx) #t))) (_ #t)))
(_ #t))))
(_ #t)) (_ #t))
(lp preds #t))))))) (lp preds #t)))))))
(lp (1+ n) first? (lp (1+ n) first?
@ -219,7 +218,6 @@ be that both true and false proofs are available."
(cont-defs kargs)) (cont-defs kargs))
(($ $kclause arity ($ $cont kargs ($ $kargs names syms))) (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
syms) syms)
(($ $kif) '())
(($ $kfun src meta self) (list self)) (($ $kfun src meta self) (list self))
(($ $ktail) '()))) (($ $ktail) '())))
(lp (1+ n)))) (lp (1+ n))))
@ -548,16 +546,9 @@ be that both true and false proofs are available."
(build-cps-term (build-cps-term
($continue (if t kt k) src ($values ())))))) ($continue (if t kt k) src ($values ()))))))
(_ (_
;; FIXME: can we always continue with $values? why
;; or why not?
(rewrite-cps-term (lookup-cont k dfg) (rewrite-cps-term (lookup-cont k dfg)
(($ $kif kt kf)
,(let* ((bool (vector-ref boolv (label->idx label)))
(t (bitvector-ref bool (true-idx eidx)))
(f (bitvector-ref bool (false-idx eidx))))
(if (eqv? t f)
(build-cps-term
($continue k src ,(visit-exp exp)))
(build-cps-term
($continue (if t kt kf) src ($values ()))))))
(($ $kargs) (($ $kargs)
($continue k src ($values vars))) ($continue k src ($values vars)))
(_ (_

2
module/language/cps/dce.scm
View file

@ -74,7 +74,6 @@
(cont-defs kargs)) (cont-defs kargs))
(($ $kclause arity ($ $cont kargs ($ $kargs names syms))) (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
syms) syms)
(($ $kif) #f)
(($ $kfun src meta self) (list self)) (($ $kfun src meta self) (list self))
(($ $ktail) #f))) (($ $ktail) #f)))
(lp (1+ n)))) (lp (1+ n))))
@ -236,7 +235,6 @@
(mark-live! use))) (mark-live! use)))
args defs)))))))))) args defs))))))))))
(($ $kreceive arity kargs) #f) (($ $kreceive arity kargs) #f)
(($ $kif) #f)
(($ $kclause arity ($ $cont kargs ($ $kargs names syms body))) (($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
(for-each mark-live! syms)) (for-each mark-live! syms))
(($ $kfun src meta self) (($ $kfun src meta self)

7
module/language/cps/dfg.scm
View file

@ -107,7 +107,7 @@
min-label max-label label-count min-label max-label label-count
min-var max-var var-count) min-var max-var var-count)
dfg? dfg?
;; vector of label -> $kif, $kargs, etc ;; vector of label -> $kargs, etc
(conts dfg-cont-table) (conts dfg-cont-table)
;; vector of label -> (pred-label ...) ;; vector of label -> (pred-label ...)
(preds dfg-preds) (preds dfg-preds)
@ -816,9 +816,6 @@ body continuation in the prompt."
(($ $kargs names syms body) (($ $kargs names syms body)
(for-each (cut add-def! <> label) syms) (for-each (cut add-def! <> label) syms)
(visit-term body label)) (visit-term body label))
(($ $kif kt kf)
(link-blocks! label kt)
(link-blocks! label kf))
(($ $kreceive arity k) (($ $kreceive arity k)
(link-blocks! label k)))) (link-blocks! label k))))
@ -917,8 +914,6 @@ body continuation in the prompt."
(newline port)) (newline port))
(format port "k~a:~8t" label) (format port "k~a:~8t" label)
(match cont (match cont
(($ $kif kt kf)
(format port "$kif k~a k~a\n" kt kf))
(($ $kreceive arity k) (($ $kreceive arity k)
(format port "$kreceive ~a k~a\n" arity k)) (format port "$kreceive ~a k~a\n" arity k))
(($ $kfun src meta self tail clause) (($ $kfun src meta self tail clause)

1
module/language/cps/effects-analysis.scm
View file

@ -467,7 +467,6 @@ is or might be a read or a write to the same location as A."
(($ $arity _ () #f () #f) &type-check) (($ $arity _ () #f () #f) &type-check)
(($ $arity () () _ () #f) (&allocate &pair)) (($ $arity () () _ () #f) (&allocate &pair))
(($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check)))) (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
(($ $kif) &no-effects)
(($ $kfun) &type-check) (($ $kfun) &type-check)
(($ $kclause) &type-check) (($ $kclause) &type-check)
(($ $ktail) &no-effects))) (($ $ktail) &no-effects)))

4
module/language/cps/prune-top-level-scopes.scm
View file

@ -46,7 +46,7 @@
(($ $cont k ($ $kclause arity body alternate)) (($ $cont k ($ $kclause arity body alternate))
(visit-cont body) (visit-cont body)
(when alternate (visit-cont alternate))) (when alternate (visit-cont alternate)))
(($ $cont k (or ($ $kreceive) ($ $kif))) (($ $cont k ($ $kreceive))
#t))) #t)))
(define (visit-term term) (define (visit-term term)
(match term (match term
@ -99,7 +99,7 @@
(($ $cont sym ($ $kclause arity body alternate)) (($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body) (sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate))))) ,(and alternate (visit-cont alternate)))))
(($ $cont sym (or ($ $kreceive) ($ $kif))) (($ $cont sym ($ $kreceive))
,cont))) ,cont)))
(define (visit-term term) (define (visit-term term)
(rewrite-cps-term term (rewrite-cps-term term

8
module/language/cps/renumber.scm
View file

@ -100,7 +100,7 @@
(visit-cont body) (visit-cont body)
(when alternate (when alternate
(visit-cont alternate))) (visit-cont alternate)))
((or ($ $ktail) ($ $kreceive) ($ $kif)) ((or ($ $ktail) ($ $kreceive))
#f))))) #f)))))
(define (visit-term term) (define (visit-term term)
(match term (match term
@ -147,7 +147,7 @@
;; sure we mark as reachable. ;; sure we mark as reachable.
(vector-set! labels label next-label) (vector-set! labels label next-label)
(set! next-label (1+ next-label)))) (set! next-label (1+ next-label))))
((or ($ $kreceive) ($ $kif)) (($ $kreceive)
#f)))))) #f))))))
(define (visit-term term reachable?) (define (visit-term term reachable?)
(match term (match term
@ -225,9 +225,7 @@
($kclause ,(rename-kw-arity arity) ,(must-visit-cont body) ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
,(and alternate (must-visit-cont alternate))))) ,(and alternate (must-visit-cont alternate)))))
(($ $kreceive ($ $arity req () rest () #f) kargs) (($ $kreceive ($ $arity req () rest () #f) kargs)
(label ($kreceive req rest (relabel kargs)))) (label ($kreceive req rest (relabel kargs))))))))))
(($ $kif kt kf)
(label ($kif (relabel kt) (relabel kf))))))))))
(define (visit-term term) (define (visit-term term)
(rewrite-cps-term term (rewrite-cps-term term
(($ $letk conts body) (($ $letk conts body)

8
module/language/cps/simplify.scm
View file

@ -96,9 +96,7 @@
(sym ($kclause ,arity ,(visit-cont body sym) (sym ($kclause ,arity ,(visit-cont body sym)
,(and alternate (visit-cont alternate sym))))) ,(and alternate (visit-cont alternate sym)))))
(($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs)) (($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
(sym ($kreceive req rest (reduce kargs scope)))) (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) (define (visit-term term scope)
(rewrite-cps-term term (rewrite-cps-term term
(($ $letk conts body) (($ $letk conts body)
@ -135,7 +133,7 @@
(($ $cont sym ($ $kclause arity body alternate)) (($ $cont sym ($ $kclause arity body alternate))
(visit-cont body) (visit-cont body)
(when alternate (visit-cont alternate))) (when alternate (visit-cont alternate)))
(($ $cont sym (or ($ $ktail) ($ $kreceive) ($ $kif))) (($ $cont sym (or ($ $ktail) ($ $kreceive)))
#f))) #f)))
(define (visit-term term) (define (visit-term term)
(match term (match term
@ -192,7 +190,7 @@
(($ $kclause arity body alternate) (($ $kclause arity body alternate)
(sym ($kclause ,arity ,(must-visit-cont body) (sym ($kclause ,arity ,(must-visit-cont body)
,(and alternate (must-visit-cont alternate))))) ,(and alternate (must-visit-cont alternate)))))
((or ($ $kreceive) ($ $kif)) (($ $kreceive)
(sym ,cont))))))) (sym ,cont)))))))
(define (visit-term term) (define (visit-term term)
(match term (match term

5
module/language/cps/slot-allocation.scm
View file

@ -581,8 +581,7 @@ are comparable with eqv?. A tmp slot may be used."
(compute-tmp-slot (logior pre-live result-live) (compute-tmp-slot (logior pre-live result-live)
'())))) '()))))
(hashq-set! call-allocations label (hashq-set! call-allocations label
(make-call-allocation #f moves #f)))) (make-call-allocation #f moves #f))))))
(($ $kif) #f)))
(define (allocate-prompt label k handler nargs) (define (allocate-prompt label k handler nargs)
(match (lookup-cont handler dfg) (match (lookup-cont handler dfg)
@ -652,7 +651,7 @@ are comparable with eqv?. A tmp slot may be used."
(allocate-prompt label k handler nargs)) (allocate-prompt label k handler nargs))
(_ #f))) (_ #f)))
(lp (1+ n) post-live)) (lp (1+ n) post-live))
((or ($ $kreceive) ($ $kif) ($ $ktail)) ((or ($ $kreceive) ($ $ktail))
(lp (1+ n) post-live))))))) (lp (1+ n) post-live)))))))
(define (visit-entry) (define (visit-entry)

31
module/language/cps/type-fold.scm
View file

@ -187,20 +187,11 @@
(($ $letrec _ _ _ body) (($ $letrec _ _ _ body)
(visit-term body label)) (visit-term body label))
(($ $continue k src ($ $primcall name args)) (($ $continue k src ($ $primcall name args))
;; We might be able to fold primcalls that define a value or ;; We might be able to fold primcalls that define a value.
;; that branch.
(match (lookup-cont k dfg) (match (lookup-cont k dfg)
(($ $kargs (_) (def)) (($ $kargs (_) (def))
(maybe-fold-value! (label->idx label) name (label->idx k) (maybe-fold-value! (label->idx label) name (label->idx k)
(var->idx def))) (var->idx def)))
(($ $kif kt kf)
(match args
((arg)
(maybe-fold-unary-branch! (label->idx label) name
(var->idx arg)))
((arg0 arg1)
(maybe-fold-binary-branch! (label->idx label) name
(var->idx arg0) (var->idx arg1)))))
(_ #f))) (_ #f)))
(($ $continue kf src ($ $branch kt ($ $primcall name args))) (($ $continue kf src ($ $branch kt ($ $primcall name args)))
;; We might be able to fold primcalls that branch. ;; We might be able to fold primcalls that branch.
@ -249,19 +240,13 @@
(let ((val (vector-ref folded-values (label->idx label)))) (let ((val (vector-ref folded-values (label->idx label))))
;; Uncomment for debugging. ;; Uncomment for debugging.
;; (pk 'folded src primcall val) ;; (pk 'folded src primcall val)
(match (lookup-cont k dfg) (let-fresh (k*) (v*)
(($ $kargs) ;; Rely on DCE to elide this expression, if
(let-fresh (k*) (v*) ;; possible.
;; Rely on DCE to elide this expression, if (build-cps-term
;; possible. ($letk ((k* ($kargs (#f) (v*)
(build-cps-term ($continue k src ($const val)))))
($letk ((k* ($kargs (#f) (v*) ($continue k* src ,primcall)))))
($continue k src ($const val)))))
($continue k* src ,primcall)))))
(($ $kif kt kf)
;; Folded branch.
(build-cps-term
($continue (if val kt kf) src ($values ()))))))
term)) term))
(($ $continue kf src ($ $branch kt ($ $primcall))) (($ $continue kf src ($ $branch kt ($ $primcall)))
,(if (and folded? ,(if (and folded?

50
module/language/cps/types.scm
View file

@ -1276,7 +1276,7 @@ mapping symbols to types."
(($ $kargs (_) (var)) (($ $kargs (_) (var))
(let ((def (var->idx var))) (let ((def (var->idx var)))
(infer-primcall! post name (map var->idx args) def))) (infer-primcall! post name (map var->idx args) def)))
((or ($ $kargs ()) ($ $kif)) (($ $kargs ())
(infer-primcall! post name (map var->idx args) #f)) (infer-primcall! post name (map var->idx args) #f))
(_ #f))) (_ #f)))
(($ $values args) (($ $values args)
@ -1354,54 +1354,6 @@ mapping symbols to types."
(match exp (match exp
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(propagate-types! handler post)) (propagate-types! handler post))
(_ #f))
(match (lookup-cont k dfg)
;; We propagate one step farther for conditionals.
;; Unfortunately we have to duplicate the
;; changed-types logic. This is unavoidable as a $kif
;; node has two successors but only one post-types
;; set.
(($ $kif kt kf)
(let ((kt-out tmp)
(kf-out tmp2))
(define (update-changelist! k from var)
(let ((to (get-pre-types k)))
(unless (or (< var 0)
(bitvector-ref changed-types var)
(= (logior (var-type from var)
(var-type to var))
(var-type to var)))
(bitvector-set! changed-types var #t))
(unless (or (< var 0)
(bitvector-ref changed-ranges var)
(and
(<= (var-min to var) (var-min from var))
(<= (var-max from var) (var-max to var))))
(bitvector-set! changed-ranges var #t))))
(bytevector-copy! post 0 kt-out 0 (bytevector-length post))
(bytevector-copy! post 0 kf-out 0 (bytevector-length post))
(let lp ((args (match exp
(($ $values (arg))
(let* ((arg (var->idx arg)))
(restrict! kf-out arg
(logior &boolean &nil) 0 0)
(list arg)))
(($ $primcall name args)
(let ((args (map var->idx args)))
(infer-predicate! kt-out name args #t)
(infer-predicate! kf-out name args #f)
args)))))
(match args
((arg . args)
(update-changelist! kt kt-out arg)
(update-changelist! kf kf-out arg)
(lp args))
(_ #f)))
;; Although "k" might dominate "kt", it's not
;; necessarily the case that "label" dominates
;; "kt". The perils of lookahead.
(propagate-types/slow! kt kt-out)
(propagate-types/slow! kf kf-out)))
(_ #f))))) (_ #f)))))
(($ $kreceive arity k*) (($ $kreceive arity k*)
(propagate-types! k* post)) (propagate-types! k* post))

3
module/language/cps/verify.scm
View file

@ -72,9 +72,6 @@
(define (visit-cont-body cont k-env v-env) (define (visit-cont-body cont k-env v-env)
(match cont (match cont
(($ $kif kt kf)
(check-label kt k-env)
(check-label kf k-env))
(($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k) (($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
(check-label k k-env)) (check-label k k-env))
(($ $kargs (name ...) (sym ...) body) (($ $kargs (name ...) (sym ...) body)