[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-43-g59258f7
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-43-g59258f7 |
|
Date: |
Mon, 02 Jun 2014 13:03:33 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=59258f7cad38327cb32278f64ec53eb6ba63a3df
The branch, master has been updated
via 59258f7cad38327cb32278f64ec53eb6ba63a3df (commit)
via fd61004764931116bcf2d9875b2aa7dc05992d7c (commit)
via 92805e219789654115f741b7d621bc9947833379 (commit)
via c90e2c608744c0c1f2e94f9c75c5a298feccbf9d (commit)
via 51177f351580884df2926d82d9da23d74e32edea (commit)
via 5062a56df049c52aa6d017808e4086965d945530 (commit)
from 146c8e72a9ff4a1d38e3d5542587777ffe1d4f61 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 59258f7cad38327cb32278f64ec53eb6ba63a3df
Author: Andy Wingo <address@hidden>
Date: Sat May 31 21:43:12 2014 -0400
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.
commit fd61004764931116bcf2d9875b2aa7dc05992d7c
Author: Andy Wingo <address@hidden>
Date: Sat May 31 21:13:33 2014 -0400
CPS conversion produces $branch nodes, not $kif
* module/language/tree-il/compile-cps.scm (unbound?, convert): Create
$branch nodes instead of $kif nodes.
commit 92805e219789654115f741b7d621bc9947833379
Author: Andy Wingo <address@hidden>
Date: Tue May 27 11:49:42 2014 -0400
Add $branch expression type
* module/language/cps.scm ($branch): New expression type; will replace
$kif.
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* 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/primitives.scm:
* module/language/cps/renumber.scm:
* module/language/cps/self-references.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 to $branch expression type.
commit c90e2c608744c0c1f2e94f9c75c5a298feccbf9d
Author: Andy Wingo <address@hidden>
Date: Fri May 30 11:54:56 2014 -0400
Fix source-line-for-user for unknown line
* module/system/vm/debug.scm (source-line-for-user): Fix to allow for
unknown lines.
commit 51177f351580884df2926d82d9da23d74e32edea
Author: Andy Wingo <address@hidden>
Date: Wed May 28 12:50:15 2014 -0400
Fix off-by-one in dump-dfg
* module/language/cps/dfg.scm (dump-dfg): Fix bug where the last
continuation wasn't printed.
commit 5062a56df049c52aa6d017808e4086965d945530
Author: Andy Wingo <address@hidden>
Date: Wed May 28 10:46:19 2014 -0400
Fix compute-predecessors bug in frame.scm
* module/system/vm/frame.scm (compute-predecessors): Fix bug in
resolving targets of backwards branches.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps.scm | 30 +++----
module/language/cps/arities.scm | 3 +
module/language/cps/closure-conversion.scm | 16 ++++
module/language/cps/compile-bytecode.scm | 10 ++-
module/language/cps/cse.scm | 59 +++++++------
module/language/cps/dce.scm | 27 ++++--
module/language/cps/dfg.scm | 20 +++--
module/language/cps/effects-analysis.scm | 3 +-
module/language/cps/primitives.scm | 3 +-
module/language/cps/prune-top-level-scopes.scm | 4 +-
module/language/cps/renumber.scm | 10 +-
module/language/cps/self-references.scm | 2 +
module/language/cps/simplify.scm | 48 +++++-----
module/language/cps/slot-allocation.scm | 11 ++-
module/language/cps/type-fold.scm | 48 ++++++-----
module/language/cps/types.scm | 108 +++++++++++++-----------
module/language/cps/verify.scm | 9 ++-
module/language/tree-il/compile-cps.scm | 26 +++---
module/system/vm/debug.scm | 2 +-
module/system/vm/frame.scm | 2 +-
20 files changed, 250 insertions(+), 191 deletions(-)
diff --git a/module/language/cps.scm b/module/language/cps.scm
index 2867a4a..f570921 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -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,10 +119,10 @@
$cont
;; Continuation bodies.
- $kif $kreceive $kargs $kfun $ktail $kclause
+ $kreceive $kargs $kfun $ktail $kclause
;; Expressions.
- $void $const $prim $fun $closure
+ $void $const $prim $fun $closure $branch
$call $callk $primcall $values $prompt
;; First-order CPS root.
@@ -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)
@@ -194,6 +193,7 @@
(define-cps-type $prim name)
(define-cps-type $fun free body) ; Higher-order.
(define-cps-type $closure label nfree) ; First-order.
+(define-cps-type $branch k exp)
(define-cps-type $call proc args)
(define-cps-type $callk k proc args) ; First-order.
(define-cps-type $primcall name args)
@@ -238,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))
@@ -266,7 +264,7 @@
(define-syntax build-cps-exp
(syntax-rules (unquote
- $void $const $prim $fun $closure
+ $void $const $prim $fun $closure $branch
$call $callk $primcall $values $prompt)
((_ (unquote exp)) exp)
((_ ($void)) (make-$void))
@@ -286,6 +284,7 @@
((_ ($values (unquote args))) (make-$values args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args))
+ ((_ ($branch k exp)) (make-$branch k (build-cps-exp exp)))
((_ ($prompt escape? tag handler))
(make-$prompt escape? tag handler))))
@@ -354,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)
@@ -404,6 +401,8 @@
(build-cps-exp ($callk k proc arg)))
(('primcall name arg ...)
(build-cps-exp ($primcall name arg)))
+ (('branch k exp)
+ (build-cps-exp ($branch k ,(parse-cps exp))))
(('values arg ...)
(build-cps-exp ($values arg)))
(('prompt escape? tag handler)
@@ -425,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)
@@ -467,6 +464,8 @@
`(callk ,k ,proc ,@args))
(($ $primcall name args)
`(primcall ,name ,@args))
+ (($ $branch k exp)
+ `(branch ,k ,(unparse-cps exp)))
(($ $values args)
`(values ,@args))
(($ $prompt escape? tag handler)
@@ -623,10 +622,9 @@
(($ $continue k src exp)
(match exp
(($ $prompt escape? tag handler) (proc k handler))
+ (($ $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))
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index c189558..c8a9728 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -148,6 +148,9 @@
;; adapt the return to the target continuation, and we don't
;; need to do any adapting here.
($continue k src ,exp))
+ (($ $branch)
+ ;; Assume branching primcalls have the correct arity.
+ ($continue k src ,exp))
(($ $primcall 'return (arg))
;; Primcalls to return are in tail position.
($continue ktail src ,exp))
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 26737e9..89e2090 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -126,6 +126,8 @@
(($ $primcall name args)
(for-each clear-well-known! args)
(fold adjoin '() args))
+ (($ $branch kt exp)
+ (visit-exp exp bound))
(($ $values args)
(for-each clear-well-known! args)
(fold adjoin '() args))
@@ -498,6 +500,20 @@ bound to @var{var}, and continue with @var{body}."
(build-cps-term
($continue k src ($primcall name args))))))
+ (($ $continue k src ($ $branch kt ($ $primcall name args)))
+ (convert-free-vars args
+ (lambda (args)
+ (build-cps-term
+ ($continue k src
+ ($branch kt ($primcall name args)))))))
+
+ (($ $continue k src ($ $branch kt ($ $values (arg))))
+ (convert-free-var arg
+ (lambda (arg)
+ (build-cps-term
+ ($continue k src
+ ($branch kt ($values (arg))))))))
+
(($ $continue k src ($ $values args))
(convert-free-vars args
(lambda (args)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index af5e1cc..25626a3 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -189,13 +189,15 @@
(compile-value label exp dst nlocals)))
(maybe-emit-jump))
(($ $kargs () ())
- (compile-effect label exp k nlocals)
- (maybe-emit-jump))
+ (match exp
+ (($ $branch kt exp)
+ (compile-test label exp kt k (1+ label)))
+ (_
+ (compile-effect label exp k nlocals)
+ (maybe-emit-jump))))
(($ $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
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 5251622..64dab7f 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -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))))
@@ -351,6 +349,9 @@ be that both true and false proofs are available."
(($ $callk k proc args) #f)
(($ $primcall name args)
(cons* 'primcall name (map subst-var args)))
+ (($ $branch _ ($ $primcall name args))
+ (cons* 'primcall name (map subst-var args)))
+ (($ $branch) #f)
(($ $values args) #f)
(($ $prompt escape? tag handler) #f)))
@@ -514,6 +515,8 @@ be that both true and false proofs are available."
($callk k (subst-var proc) ,(map subst-var args)))
(($ $primcall name args)
($primcall name ,(map subst-var args)))
+ (($ $branch k exp)
+ ($branch k ,(visit-exp exp)))
(($ $values args)
($values ,(map subst-var args)))
(($ $prompt escape? tag handler)
@@ -531,23 +534,25 @@ be that both true and false proofs are available."
=> (match-lambda
((equiv . vars)
(let* ((eidx (label->idx equiv)))
- (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)))
- ;; There is no point in adding a case for $ktail, as
- ;; only $values, $call, or $callk can continue to
- ;; $ktail.
+ (match exp
+ (($ $branch kt exp)
+ (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
+ ($branch kt ,(visit-exp exp))))
+ (build-cps-term
+ ($continue (if t kt k) src ($values ()))))))
(_
- ($continue k src ,(visit-exp exp))))))))
+ ;; FIXME: can we always continue with $values? why
+ ;; or why not?
+ (rewrite-cps-term (lookup-cont k dfg)
+ (($ $kargs)
+ ($continue k src ($values vars)))
+ (_
+ ($continue k src ,(visit-exp exp))))))))))
(else
(build-cps-term
($continue k src ,(visit-exp exp))))))))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 5f5e58c..fbfd2f3 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -66,12 +66,14 @@
(match (lookup-cont (idx->label n) dfg)
(($ $kargs _ _ body)
(match (find-call body)
- (($ $continue k) (cont-defs k))))
+ (($ $continue k src exp)
+ (match exp
+ (($ $branch) #f)
+ (_ (cont-defs k))))))
(($ $kreceive arity kargs)
(cont-defs kargs))
(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
syms)
- (($ $kif) #f)
(($ $kfun src meta self) (list self))
(($ $ktail) #f)))
(lp (1+ n))))
@@ -84,6 +86,13 @@
(let ((typev (infer-types fun dfg)))
(define (idx->label idx) (+ idx min-label))
(define (var->idx var) (- var min-var))
+ (define (visit-primcall lidx fx name args)
+ (let ((args (map var->idx args)))
+ ;; Negative args are closure variables.
+ (unless (or-map negative? args)
+ (when (primcall-types-check? lidx typev name args)
+ (vector-set! effects lidx
+ (logand fx (lognot &type-check)))))))
(let lp ((lidx 0))
(when (< lidx label-count)
(let ((fx (vector-ref effects lidx)))
@@ -93,12 +102,9 @@
(($ $kargs _ _ term)
(match (find-call term)
(($ $continue k src ($ $primcall name args))
- (let ((args (map var->idx args)))
- ;; Negative args are closure variables.
- (unless (or-map negative? args)
- (when (primcall-types-check? lidx typev name args)
- (vector-set! effects lidx
- (logand fx (lognot
&type-check)))))))
+ (visit-primcall lidx fx name args))
+ (($ $continue k src ($ $branch _ ($primcall name args)))
+ (visit-primcall lidx fx name args))
(_ #f)))
(_ #f)))))
(lp (1+ lidx)))))))))
@@ -217,6 +223,10 @@
(for-each mark-live! args))
(($ $primcall name args)
(for-each mark-live! args))
+ (($ $branch k ($ $primcall name args))
+ (for-each mark-live! args))
+ (($ $branch k ($ $values (arg)))
+ (mark-live! arg))
(($ $values args)
(match (vector-ref defs n)
(#f (for-each mark-live! args))
@@ -225,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)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 7fc8ed4..593d02c 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -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))))
@@ -858,6 +855,9 @@ body continuation in the prompt."
(for-each use! args))
(($ $primcall name args)
(for-each use! args))
+ (($ $branch kt exp)
+ (link-blocks! label kt)
+ (visit-exp exp label))
(($ $values args)
(for-each use! args))
(($ $prompt escape? tag handler)
@@ -907,15 +907,13 @@ body continuation in the prompt."
(define (idx->var idx) (+ idx min-var))
(let lp ((label (dfg-min-label dfg)))
- (when (< label (dfg-max-label dfg))
+ (when (<= label (dfg-max-label dfg))
(let ((cont (vector-ref (dfg-cont-table dfg) (label->idx label))))
(when cont
(unless (equal? (lookup-predecessors label dfg) (list (1- label)))
(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)
@@ -933,6 +931,14 @@ body continuation in the prompt."
(format port "v~a[~a]~:{ v~a[~a]~}: "
(car vars) (car names) (map list (cdr vars) (cdr
names))))
(match (find-call term)
+ (($ $continue kf src ($ $branch kt exp))
+ (format port "if ")
+ (match exp
+ (($ $primcall name args)
+ (format port "(~a~{ v~a~})" name args))
+ (($ $values (arg))
+ (format port "v~a" arg)))
+ (format port " k~a k~a\n" kt kf))
(($ $continue k src exp)
(match exp
(($ $void) (format port "void"))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 98b5757..b1e2cc8 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -445,6 +445,8 @@ is or might be a read or a write to the same location as A."
(&write-object &prompt))
((or ($ $call) ($ $callk))
&all-effects)
+ (($ $branch k exp)
+ (expression-effects exp dfg))
(($ $primcall name args)
(primitive-effects dfg name args))))
@@ -465,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)))
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index 873600c..4c6287a 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -18,7 +18,8 @@
;;; Commentary:
;;;
-;;; Information about named primitives, as they appear in $prim and $primcall.
+;;; Information about named primitives, as they appear in $prim and
+;;; $primcall.
;;;
;;; Code:
diff --git a/module/language/cps/prune-top-level-scopes.scm
b/module/language/cps/prune-top-level-scopes.scm
index 2330d31..ed09074 100644
--- a/module/language/cps/prune-top-level-scopes.scm
+++ b/module/language/cps/prune-top-level-scopes.scm
@@ -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
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index ab27653..204d209 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -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)
@@ -256,6 +254,8 @@
(($ $callk k proc args)
(let ((args (map rename args)))
(build-cps-exp ($callk (relabel k) (rename proc) args))))
+ (($ $branch kt exp)
+ (build-cps-exp ($branch (relabel kt) ,(visit-exp exp))))
(($ $primcall name args)
(let ((args (map rename args)))
(build-cps-exp ($primcall name args))))
diff --git a/module/language/cps/self-references.scm
b/module/language/cps/self-references.scm
index 6911320..be4f2d9 100644
--- a/module/language/cps/self-references.scm
+++ b/module/language/cps/self-references.scm
@@ -65,6 +65,8 @@
($callk k (subst proc) ,(map subst args)))
(($ $primcall name args)
($primcall name ,(map subst args)))
+ (($ $branch k exp)
+ ($branch k ,(visit-exp exp)))
(($ $values args)
($values ,(map subst args)))
(($ $prompt escape? tag handler)
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index 0dd98e2..5185889 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -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
@@ -209,25 +207,27 @@
(cond
((hashq-ref k-table k) => visit-term)
(else
- (build-cps-term
- ($continue k src
- ,(match exp
- ((or ($ $void) ($ $const) ($ $prim)) exp)
- (($ $fun) (visit-fun exp))
- (($ $call proc args)
- (let ((args (map subst args)))
- (build-cps-exp ($call (subst proc) args))))
- (($ $callk k proc args)
- (let ((args (map subst args)))
- (build-cps-exp ($callk k (subst proc) args))))
- (($ $primcall name args)
- (let ((args (map subst args)))
- (build-cps-exp ($primcall name args))))
- (($ $values args)
- (let ((args (map subst args)))
- (build-cps-exp ($values args))))
- (($ $prompt escape? tag handler)
- (build-cps-exp ($prompt escape? (subst tag)
handler)))))))))))
+ (build-cps-term ($continue k src ,(visit-exp exp))))))))
+ (define (visit-exp exp)
+ (match exp
+ ((or ($ $void) ($ $const) ($ $prim)) exp)
+ (($ $fun) (visit-fun exp))
+ (($ $call proc args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($call (subst proc) args))))
+ (($ $callk k proc args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($callk k (subst proc) args))))
+ (($ $primcall name args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($primcall name args))))
+ (($ $values args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($values args))))
+ (($ $branch kt exp)
+ (build-cps-exp ($branch kt ,(visit-exp exp))))
+ (($ $prompt escape? tag handler)
+ (build-cps-exp ($prompt escape? (subst tag) handler)))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun free body)
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 53d6cee..6ba3054 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -362,6 +362,10 @@ are comparable with eqv?. A tmp slot may be used."
(cons proc args))
(($ $primcall name args)
args)
+ (($ $branch kt ($ $primcall name args))
+ args)
+ (($ $branch kt ($ $values args))
+ args)
(($ $values args)
args)
(($ $prompt escape? tag handler)
@@ -461,7 +465,7 @@ are comparable with eqv?. A tmp slot may be used."
(if (bit-position #t dead 0)
(finish-hints n (live-before n) args)
(scan-for-hints (1- n) args))))
- ((or ($ $call) ($ $callk) ($ $values))
+ ((or ($ $call) ($ $callk) ($ $values) ($ $branch))
(finish-hints n (live-before n) args))))
;; Otherwise we kill uses of the block entry.
(_ (finish-hints n (live-before (1+ n)) args))))
@@ -577,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)
@@ -648,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)
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index 91f23df..b644fd0 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -187,21 +187,21 @@
(($ $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.
+ (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)))
(when typev
(match fun
@@ -240,19 +240,21 @@
(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?
+ (bitvector-ref folded? (label->idx label)))
+ ;; Folded branch.
+ (let ((val (vector-ref folded-values (label->idx label))))
+ (build-cps-term
+ ($continue (if val kt kf) src ($values ()))))
term))
(_ ,term)))
(define (visit-fun fun)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 22335f7..e6689d6 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -470,6 +470,7 @@ minimum, and maximum."
(max (min (&max a) (&max b))))
(restrict! a type min max)
(restrict! b type min max))))
+;; FIXME!!!!!
(define-type-inferrer-aliases eq? eqv? equal?)
(define-syntax-rule (define-simple-predicate-inferrer predicate type)
@@ -730,6 +731,7 @@ minimum, and maximum."
(when (zero? (logand (logior (&type a) (&type b)) (lognot &number)))
(restrict! a &real -inf.0 +inf.0)
(restrict! b &real -inf.0 +inf.0)))
+;; FIXME!!!
(define-type-aliases < <= > >=)
;; Arithmetic.
@@ -1198,7 +1200,6 @@ mapping symbols to types."
;; Add types for new definitions, and restrict types of
;; existing variables due to side effects.
(match (lookup-cont label dfg)
- ;; fixme: letrec
(($ $kargs names vars term)
(let visit-term ((term term))
(match term
@@ -1215,12 +1216,67 @@ mapping symbols to types."
(visit-term term))
(($ $continue k src exp)
(match exp
+ (($ $branch kt exp)
+ ;; The "normal" continuation is the #f branch.
+ ;; For the #t branch we need to roll our own
+ ;; "changed" logic. This will be refactored
+ ;; in the future.
+ (let ((kt-out tmp2))
+ (bytevector-copy! pre 0 kt-out 0 (bytevector-length
pre))
+ (match exp
+ (($ $values (arg))
+ (let ((arg (var->idx arg)))
+ (unless (< arg 0)
+ (bitvector-set! changed arg #t)
+ (restrict! post arg (logior &boolean &nil) 0 0))
+ ;; No additional information on the #t branch,
+ ;; as there's no way currently to remove #f
+ ;; from the typeset (because it would remove
+ ;; #t as well: they are both &boolean).
+ ))
+ (($ $primcall name args)
+ (let ((args (map var->idx args)))
+ ;; For the #t branch we need to roll our own
+ ;; "changed" logic. This will be refactored
+ ;; in the future.
+ (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))))
+ ;; The "normal" continuation is the #f branch.
+ (infer-predicate! post name args #f)
+ (infer-predicate! kt-out name args #t)
+ (let lp ((args args))
+ (match args
+ ((arg . args)
+ ;; Primcall operands can originate
+ ;; outside the function.
+ (when (<= 0 arg)
+ ;; `out' will be scanned below.
+ (bitvector-set! changed arg #t)
+ ;; But we need to manually scan
+ ;; kt-out.
+ (update-changelist! kt kt-out arg))
+ (lp args))
+ (_ #f))))))
+ ;; Manually propagate the kt branch.
+ (propagate-types! kt kt-out)))
(($ $primcall name args)
(match (lookup-cont k dfg)
(($ $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)
@@ -1298,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))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index b965427..a39e99b 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -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)
@@ -158,6 +155,12 @@
;; the reference.
(check-var proc v-env)
(for-each (cut check-var <> v-env) arg))
+ (($ $branch kt ($ $primcall (? symbol? name) (arg ...)))
+ (check-var kt k-env)
+ (for-each (cut check-var <> v-env) arg))
+ (($ $branch kt ($ $values (arg ...)))
+ (check-var kt k-env)
+ (for-each (cut check-var <> v-env) arg))
(($ $primcall (? symbol? name) (arg ...))
(for-each (cut check-var <> v-env) arg))
(($ $values (arg ...))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 96f27cd..d81a82c 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -167,13 +167,12 @@
(define tc8-iflag 4)
(define unbound-val 9)
(define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
- (let-fresh (ktest) (unbound)
+ (let-fresh () (unbound)
(build-cps-term
($letconst (('unbound unbound
(pointer->scm (make-pointer unbound-bits))))
- ($letk ((ktest ($kif kt kf)))
- ($continue ktest src
- ($primcall 'eq? (var unbound))))))))
+ ($continue kf src
+ ($branch kt ($primcall 'eq? (var unbound))))))))
(define (init-default-value name sym subst init body)
(match (hashq-ref subst sym)
@@ -358,12 +357,12 @@
((branching-primitive? name)
(convert-args args
(lambda (args)
- (let-fresh (kt kf kif) ()
+ (let-fresh (kt kf) ()
(build-cps-term
($letk ((kt ($kargs () () ($continue k src ($const #t))))
- (kf ($kargs () () ($continue k src ($const #f))))
- (kif ($kif kt kf)))
- ($continue kif src ($primcall name args))))))))
+ (kf ($kargs () () ($continue k src ($const #f)))))
+ ($continue kf src
+ ($branch kt ($primcall name args)))))))))
((and (eq? name 'list)
(and-map (match-lambda
((or ($ <const>)
@@ -467,21 +466,22 @@
($continue k src ($primcall 'apply args*))))))
(($ <conditional> src test consequent alternate)
- (let-fresh (kif kt kf) ()
+ (let-fresh (kt kf) ()
(build-cps-term
($letk* ((kt ($kargs () () ,(convert consequent k subst)))
- (kf ($kargs () () ,(convert alternate k subst)))
- (kif ($kif kt kf)))
+ (kf ($kargs () () ,(convert alternate k subst))))
,(match test
(($ <primcall> src (? branching-primitive? name) args)
(convert-args args
(lambda (args)
(build-cps-term
- ($continue kif src ($primcall name args))))))
+ ($continue kf src
+ ($branch kt ($primcall name args)))))))
(_ (convert-arg test
(lambda (test)
(build-cps-term
- ($continue kif src ($values (test))))))))))))
+ ($continue kf src
+ ($branch kt ($values (test)))))))))))))
(($ <lexical-set> src name gensym exp)
(convert-arg exp
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 97c3d99..cd8c19e 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -657,7 +657,7 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
;; one-indexed. Columns, on the other hand, are zero-indexed to both. Go
;; figure.
(define (source-line-for-user source)
- (1+ (source-line source)))
+ (and (source-line source) (1+ (source-line source))))
(define* (find-source-for-addr addr #:optional
(context (find-debug-context addr))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 776109f..ac5fbf6 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -64,7 +64,7 @@
(let lp ((to from) (target target))
(cond
((negative? target)
- (lp (1- to) (+ target (vector-ref parsed to))))
+ (lp (1- to) (+ target (vector-ref parsed (1- to)))))
((positive? target)
(lp (1+ to) (- target (vector-ref parsed to))))
((= to (vector-length preds))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-43-g59258f7,
Andy Wingo <=