mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
Remove $kif
* 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
parent
fd61004764
commit
59258f7cad
13 changed files with 36 additions and 135 deletions
|
|
@ -27,8 +27,8 @@
|
|||
;;; $letk binds a set of mutually recursive continuations, each one an
|
||||
;;; instance of $cont. A $cont declares the name of a continuation, and
|
||||
;;; then contains as a subterm the particular continuation instance:
|
||||
;;; $kif for test continuations, $kargs for continuations that bind
|
||||
;;; values, etc.
|
||||
;;; $kargs for continuations that bind values, $ktail for the tail
|
||||
;;; continuation, etc.
|
||||
;;;
|
||||
;;; $continue nodes call continuations. The expression contained in the
|
||||
;;; $continue node determines the value or values that are passed to the
|
||||
|
|
@ -92,7 +92,7 @@
|
|||
;;; - $letk, $letrec, and $continue are terms.
|
||||
;;;
|
||||
;;; - $cont is a continuation, containing a continuation body ($kargs,
|
||||
;;; $kif, etc).
|
||||
;;; $ktail, etc).
|
||||
;;;
|
||||
;;; - $continue terms contain an expression ($call, $const, $fun,
|
||||
;;; etc).
|
||||
|
|
@ -119,7 +119,7 @@
|
|||
$cont
|
||||
|
||||
;; Continuation bodies.
|
||||
$kif $kreceive $kargs $kfun $ktail $kclause
|
||||
$kreceive $kargs $kfun $ktail $kclause
|
||||
|
||||
;; Expressions.
|
||||
$void $const $prim $fun $closure $branch
|
||||
|
|
@ -181,7 +181,6 @@
|
|||
|
||||
;; Continuations
|
||||
(define-cps-type $cont k cont)
|
||||
(define-cps-type $kif kt kf)
|
||||
(define-cps-type $kreceive arity k)
|
||||
(define-cps-type $kargs names syms body)
|
||||
(define-cps-type $kfun src meta self tail clause)
|
||||
|
|
@ -239,11 +238,9 @@
|
|||
(make-$arity req opt rest kw allow-other-keys?))))
|
||||
|
||||
(define-syntax build-cont-body
|
||||
(syntax-rules (unquote $kif $kreceive $kargs $kfun $ktail $kclause)
|
||||
(syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
|
||||
((_ (unquote exp))
|
||||
exp)
|
||||
((_ ($kif kt kf))
|
||||
(make-$kif kt kf))
|
||||
((_ ($kreceive req rest kargs))
|
||||
(make-$kreceive (make-$arity req '() rest '() #f) kargs))
|
||||
((_ ($kargs (name ...) (unquote syms) body))
|
||||
|
|
@ -356,8 +353,6 @@
|
|||
(('k sym body)
|
||||
(build-cps-cont
|
||||
(sym ,(parse-cps body))))
|
||||
(('kif kt kf)
|
||||
(build-cont-body ($kif kt kf)))
|
||||
(('kreceive req rest k)
|
||||
(build-cont-body ($kreceive req rest k)))
|
||||
(('kargs names syms body)
|
||||
|
|
@ -429,8 +424,6 @@
|
|||
`(letk ,(map unparse-cps conts) ,(unparse-cps body)))
|
||||
(($ $cont sym body)
|
||||
`(k ,sym ,(unparse-cps body)))
|
||||
(($ $kif kt kf)
|
||||
`(kif ,kt ,kf))
|
||||
(($ $kreceive ($ $arity req () rest '() #f) k)
|
||||
`(kreceive ,req ,rest ,k))
|
||||
(($ $kargs () () body)
|
||||
|
|
@ -632,8 +625,6 @@
|
|||
(($ $branch kt) (proc k kt))
|
||||
(_ (proc k)))))))
|
||||
|
||||
(($ $kif kt kf) (proc kt kf))
|
||||
|
||||
(($ $kreceive arity k) (proc k))
|
||||
|
||||
(($ $kclause arity ($ $cont kbody) #f) (proc kbody))
|
||||
|
|
|
|||
|
|
@ -198,8 +198,6 @@
|
|||
(($ $kargs names syms)
|
||||
(compile-values label exp syms)
|
||||
(maybe-emit-jump))
|
||||
(($ $kif kt kf)
|
||||
(compile-test label exp kt kf (and fallthrough? (1+ k))))
|
||||
(($ $kreceive ($ $arity req () rest () #f) kargs)
|
||||
(compile-trunc label k exp (length req)
|
||||
(and rest
|
||||
|
|
|
|||
|
|
@ -177,16 +177,15 @@ be that both true and false proofs are available."
|
|||
(if initialized?
|
||||
(intersect! bool (vector-ref boolv pidx))
|
||||
(bitvector-copy! bool (vector-ref boolv pidx)))
|
||||
(match (lookup-predecessors pred dfg)
|
||||
((test)
|
||||
(let ((tidx (label->idx test)))
|
||||
(match (lookup-cont pred dfg)
|
||||
(($ $kif kt kf)
|
||||
(when (eqv? kt label)
|
||||
(bitvector-set! bool (true-idx tidx) #t))
|
||||
(when (eqv? kf label)
|
||||
(bitvector-set! bool (false-idx tidx) #t)))
|
||||
(_ #t))))
|
||||
(match (lookup-cont pred dfg)
|
||||
(($ $kargs _ _ term)
|
||||
(match (find-call term)
|
||||
(($ $continue kf ($ $branch kt exp))
|
||||
(when (eqv? kt label)
|
||||
(bitvector-set! bool (true-idx pidx) #t))
|
||||
(when (eqv? kf label)
|
||||
(bitvector-set! bool (false-idx pidx) #t)))
|
||||
(_ #t)))
|
||||
(_ #t))
|
||||
(lp preds #t)))))))
|
||||
(lp (1+ n) first?
|
||||
|
|
@ -219,7 +218,6 @@ be that both true and false proofs are available."
|
|||
(cont-defs kargs))
|
||||
(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
|
||||
syms)
|
||||
(($ $kif) '())
|
||||
(($ $kfun src meta self) (list self))
|
||||
(($ $ktail) '())))
|
||||
(lp (1+ n))))
|
||||
|
|
@ -548,16 +546,9 @@ be that both true and false proofs are available."
|
|||
(build-cps-term
|
||||
($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)
|
||||
(($ $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)
|
||||
($continue k src ($values vars)))
|
||||
(_
|
||||
|
|
|
|||
|
|
@ -74,7 +74,6 @@
|
|||
(cont-defs kargs))
|
||||
(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
|
||||
syms)
|
||||
(($ $kif) #f)
|
||||
(($ $kfun src meta self) (list self))
|
||||
(($ $ktail) #f)))
|
||||
(lp (1+ n))))
|
||||
|
|
@ -236,7 +235,6 @@
|
|||
(mark-live! use)))
|
||||
args defs))))))))))
|
||||
(($ $kreceive arity kargs) #f)
|
||||
(($ $kif) #f)
|
||||
(($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
|
||||
(for-each mark-live! syms))
|
||||
(($ $kfun src meta self)
|
||||
|
|
|
|||
|
|
@ -107,7 +107,7 @@
|
|||
min-label max-label label-count
|
||||
min-var max-var var-count)
|
||||
dfg?
|
||||
;; vector of label -> $kif, $kargs, etc
|
||||
;; vector of label -> $kargs, etc
|
||||
(conts dfg-cont-table)
|
||||
;; vector of label -> (pred-label ...)
|
||||
(preds dfg-preds)
|
||||
|
|
@ -816,9 +816,6 @@ body continuation in the prompt."
|
|||
(($ $kargs names syms body)
|
||||
(for-each (cut add-def! <> label) syms)
|
||||
(visit-term body label))
|
||||
(($ $kif kt kf)
|
||||
(link-blocks! label kt)
|
||||
(link-blocks! label kf))
|
||||
(($ $kreceive arity k)
|
||||
(link-blocks! label k))))
|
||||
|
||||
|
|
@ -917,8 +914,6 @@ body continuation in the prompt."
|
|||
(newline port))
|
||||
(format port "k~a:~8t" label)
|
||||
(match cont
|
||||
(($ $kif kt kf)
|
||||
(format port "$kif k~a k~a\n" kt kf))
|
||||
(($ $kreceive arity k)
|
||||
(format port "$kreceive ~a k~a\n" arity k))
|
||||
(($ $kfun src meta self tail clause)
|
||||
|
|
|
|||
|
|
@ -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) (&allocate &pair))
|
||||
(($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
|
||||
(($ $kif) &no-effects)
|
||||
(($ $kfun) &type-check)
|
||||
(($ $kclause) &type-check)
|
||||
(($ $ktail) &no-effects)))
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@
|
|||
(($ $cont k ($ $kclause arity body alternate))
|
||||
(visit-cont body)
|
||||
(when alternate (visit-cont alternate)))
|
||||
(($ $cont k (or ($ $kreceive) ($ $kif)))
|
||||
(($ $cont k ($ $kreceive))
|
||||
#t)))
|
||||
(define (visit-term term)
|
||||
(match term
|
||||
|
|
@ -99,7 +99,7 @@
|
|||
(($ $cont sym ($ $kclause arity body alternate))
|
||||
(sym ($kclause ,arity ,(visit-cont body)
|
||||
,(and alternate (visit-cont alternate)))))
|
||||
(($ $cont sym (or ($ $kreceive) ($ $kif)))
|
||||
(($ $cont sym ($ $kreceive))
|
||||
,cont)))
|
||||
(define (visit-term term)
|
||||
(rewrite-cps-term term
|
||||
|
|
|
|||
|
|
@ -100,7 +100,7 @@
|
|||
(visit-cont body)
|
||||
(when alternate
|
||||
(visit-cont alternate)))
|
||||
((or ($ $ktail) ($ $kreceive) ($ $kif))
|
||||
((or ($ $ktail) ($ $kreceive))
|
||||
#f)))))
|
||||
(define (visit-term term)
|
||||
(match term
|
||||
|
|
@ -147,7 +147,7 @@
|
|||
;; sure we mark as reachable.
|
||||
(vector-set! labels label next-label)
|
||||
(set! next-label (1+ next-label))))
|
||||
((or ($ $kreceive) ($ $kif))
|
||||
(($ $kreceive)
|
||||
#f))))))
|
||||
(define (visit-term term reachable?)
|
||||
(match term
|
||||
|
|
@ -225,9 +225,7 @@
|
|||
($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))))))))))
|
||||
(label ($kreceive req rest (relabel kargs))))))))))
|
||||
(define (visit-term term)
|
||||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
|
|
|
|||
|
|
@ -96,9 +96,7 @@
|
|||
(sym ($kclause ,arity ,(visit-cont body sym)
|
||||
,(and alternate (visit-cont alternate sym)))))
|
||||
(($ $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))))))
|
||||
(sym ($kreceive req rest (reduce kargs scope))))))
|
||||
(define (visit-term term scope)
|
||||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
|
|
@ -135,7 +133,7 @@
|
|||
(($ $cont sym ($ $kclause arity body alternate))
|
||||
(visit-cont body)
|
||||
(when alternate (visit-cont alternate)))
|
||||
(($ $cont sym (or ($ $ktail) ($ $kreceive) ($ $kif)))
|
||||
(($ $cont sym (or ($ $ktail) ($ $kreceive)))
|
||||
#f)))
|
||||
(define (visit-term term)
|
||||
(match term
|
||||
|
|
@ -192,7 +190,7 @@
|
|||
(($ $kclause arity body alternate)
|
||||
(sym ($kclause ,arity ,(must-visit-cont body)
|
||||
,(and alternate (must-visit-cont alternate)))))
|
||||
((or ($ $kreceive) ($ $kif))
|
||||
(($ $kreceive)
|
||||
(sym ,cont)))))))
|
||||
(define (visit-term term)
|
||||
(match term
|
||||
|
|
|
|||
|
|
@ -581,8 +581,7 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
(compute-tmp-slot (logior pre-live result-live)
|
||||
'()))))
|
||||
(hashq-set! call-allocations label
|
||||
(make-call-allocation #f moves #f))))
|
||||
(($ $kif) #f)))
|
||||
(make-call-allocation #f moves #f))))))
|
||||
|
||||
(define (allocate-prompt label k handler nargs)
|
||||
(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))
|
||||
(_ #f)))
|
||||
(lp (1+ n) post-live))
|
||||
((or ($ $kreceive) ($ $kif) ($ $ktail))
|
||||
((or ($ $kreceive) ($ $ktail))
|
||||
(lp (1+ n) post-live)))))))
|
||||
|
||||
(define (visit-entry)
|
||||
|
|
|
|||
|
|
@ -187,20 +187,11 @@
|
|||
(($ $letrec _ _ _ body)
|
||||
(visit-term body label))
|
||||
(($ $continue k src ($ $primcall name args))
|
||||
;; We might be able to fold primcalls that define a value or
|
||||
;; that branch.
|
||||
;; We might be able to fold primcalls that define a value.
|
||||
(match (lookup-cont k dfg)
|
||||
(($ $kargs (_) (def))
|
||||
(maybe-fold-value! (label->idx label) name (label->idx k)
|
||||
(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)))
|
||||
(($ $continue kf src ($ $branch kt ($ $primcall name args)))
|
||||
;; We might be able to fold primcalls that branch.
|
||||
|
|
@ -249,19 +240,13 @@
|
|||
(let ((val (vector-ref folded-values (label->idx label))))
|
||||
;; Uncomment for debugging.
|
||||
;; (pk 'folded src primcall val)
|
||||
(match (lookup-cont k dfg)
|
||||
(($ $kargs)
|
||||
(let-fresh (k*) (v*)
|
||||
;; Rely on DCE to elide this expression, if
|
||||
;; possible.
|
||||
(build-cps-term
|
||||
($letk ((k* ($kargs (#f) (v*)
|
||||
($continue k src ($const val)))))
|
||||
($continue k* src ,primcall)))))
|
||||
(($ $kif kt kf)
|
||||
;; Folded branch.
|
||||
(build-cps-term
|
||||
($continue (if val kt kf) src ($values ()))))))
|
||||
(let-fresh (k*) (v*)
|
||||
;; Rely on DCE to elide this expression, if
|
||||
;; possible.
|
||||
(build-cps-term
|
||||
($letk ((k* ($kargs (#f) (v*)
|
||||
($continue k src ($const val)))))
|
||||
($continue k* src ,primcall)))))
|
||||
term))
|
||||
(($ $continue kf src ($ $branch kt ($ $primcall)))
|
||||
,(if (and folded?
|
||||
|
|
|
|||
|
|
@ -1276,7 +1276,7 @@ mapping symbols to types."
|
|||
(($ $kargs (_) (var))
|
||||
(let ((def (var->idx var)))
|
||||
(infer-primcall! post name (map var->idx args) def)))
|
||||
((or ($ $kargs ()) ($ $kif))
|
||||
(($ $kargs ())
|
||||
(infer-primcall! post name (map var->idx args) #f))
|
||||
(_ #f)))
|
||||
(($ $values args)
|
||||
|
|
@ -1354,54 +1354,6 @@ mapping symbols to types."
|
|||
(match exp
|
||||
(($ $prompt escape? tag handler)
|
||||
(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)))))
|
||||
(($ $kreceive arity k*)
|
||||
(propagate-types! k* post))
|
||||
|
|
|
|||
|
|
@ -72,9 +72,6 @@
|
|||
|
||||
(define (visit-cont-body cont k-env v-env)
|
||||
(match cont
|
||||
(($ $kif kt kf)
|
||||
(check-label kt k-env)
|
||||
(check-label kf k-env))
|
||||
(($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
|
||||
(check-label k k-env))
|
||||
(($ $kargs (name ...) (sym ...) body)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue