[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-226-g3aee6cf
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-226-g3aee6cf |
|
Date: |
Fri, 11 Oct 2013 11:36:01 +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=3aee6cfdd797be19dfc5f8ed8c6b7cfdd5c2695c
The branch, master has been updated
via 3aee6cfdd797be19dfc5f8ed8c6b7cfdd5c2695c (commit)
via f22979db66fb54388188ac27abd6ef59862e170b (commit)
via 6b71a7671355f22553f75e92b25e79d9bbca2154 (commit)
via 4a6d35197939e64720e4467b41cfe8ac0a917ec8 (commit)
from 61c7264fccd44cf1cd3c7401b6c23dc7c26fa9d8 (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 3aee6cfdd797be19dfc5f8ed8c6b7cfdd5c2695c
Author: Andy Wingo <address@hidden>
Date: Fri Oct 11 13:35:43 2013 +0200
Compute a dominator tree
* module/language/cps/dfg.scm (reverse-post-order, for-each/enumerate)
(convert-predecessors, finish-idoms, compute-dominator-tree): Compute
a dominator tree. We don't use it yet.
commit f22979db66fb54388188ac27abd6ef59862e170b
Author: Andy Wingo <address@hidden>
Date: Thu Oct 10 12:42:50 2013 +0200
DFG refactor to allow dominator tree construction
* module/language/cps/dfg.scm: Refactor so that we can think about
building a dominator tree. Split continuations out of use maps and
put them in a separate table, which will have more flow information.
(visit-fun): Mark clauses as using their bodies.
(lookup-predecessors, lookup-successors): New exports.
(find-defining-expression): Add an exception for clauses, now that
clauses are in the flow graph.
(continuation-bound-in?): Rename from variable-bound-in?, as it can
currently only be used for continuations.
* module/language/cps/contification.scm (contify): Adapt to use
lookup-predecessors and continuation-bound-in?.
commit 6b71a7671355f22553f75e92b25e79d9bbca2154
Author: Andy Wingo <address@hidden>
Date: Thu Oct 10 12:21:55 2013 +0200
A couple of fixes when no source info is available
* module/system/vm/assembler.scm (link-debug): If there was no debugging
info, reset the file register to 0 from its default value of 1 before
adding the final row.
* module/system/vm/dwarf.scm (line-prog-scan-to-pc): If we rescanned
from the beginning and still found no source info for this pc, return
#f instead of the default value of the file register (1).
commit 4a6d35197939e64720e4467b41cfe8ac0a917ec8
Author: Andy Wingo <address@hidden>
Date: Thu Oct 10 11:19:02 2013 +0200
Fix peval bug with inlining and optional argument initializers
* module/language/tree-il/peval.scm (peval): Fix a bug whereby inlined
function applications with default argument initializers were putting
the initializers in the wrong scope.
* test-suite/tests/peval.test ("partial evaluation"): Add a test.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps/contification.scm | 4 +-
module/language/cps/dfg.scm | 356 ++++++++++++++++++++++-----------
module/language/tree-il/peval.scm | 58 ++++--
module/system/vm/assembler.scm | 11 +-
module/system/vm/dwarf.scm | 3 +
test-suite/tests/peval.test | 10 +-
6 files changed, 300 insertions(+), 142 deletions(-)
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index dda6ee3..61f17eb 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -90,7 +90,7 @@
(define (bound-symbol k)
(match (lookup-cont k cont-table)
(($ $kargs (_) (sym))
- (match (lookup-uses k dfg)
+ (match (lookup-predecessors k dfg)
((_)
;; K has one predecessor, the one that defined SYM.
sym)
@@ -148,7 +148,7 @@
;; We have a common continuation. High fives!
;;
;; (1) Find the scope at which to contify.
- (let ((scope (if (variable-bound-in? k term-k dfg)
+ (let ((scope (if (continuation-bound-in? k term-k dfg)
term-k
(lookup-def k dfg))))
;; (2) Mark all SYMs for replacement in calls, and
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 056bd74..667d822 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -21,7 +21,7 @@
;;; Many passes rely on a local or global static analysis of a function.
;;; This module implements a simple data-flow graph (DFG) analysis,
;;; tracking the definitions and uses of variables and continuations.
-;;; It also builds a table of continuations and parent links, to be able
+;;; It also builds a table of continuations and scope links, to be able
;;; to easily determine if one continuation is in the scope of another,
;;; and to get to the expression inside a continuation.
;;;
@@ -48,13 +48,15 @@
dfg-cont-table
lookup-def
lookup-uses
+ lookup-predecessors
+ lookup-successors
find-call
call-expression
find-expression
find-defining-expression
find-constant-value
lift-definition!
- variable-bound-in?
+ continuation-bound-in?
variable-free-in?
constant-needs-allocation?
dead-after-def?
@@ -86,14 +88,14 @@
;; Data-flow graph for CPS: both for values and continuations.
(define-record-type $dfg
- (make-dfg conts use-maps uplinks)
+ (make-dfg conts blocks use-maps)
dfg?
- ;; hash table of sym -> $kargs, $kif, etc
+ ;; hash table of sym -> $kif, $kargs, etc
(conts dfg-cont-table)
+ ;; hash table of sym -> $block
+ (blocks dfg-blocks)
;; hash table of sym -> $use-map
- (use-maps dfg-use-maps)
- ;; hash table of sym -> $parent-link
- (uplinks dfg-uplinks))
+ (use-maps dfg-use-maps))
(define-record-type $use-map
(make-use-map sym def uses)
@@ -102,13 +104,116 @@
(def use-map-def)
(uses use-map-uses set-use-map-uses!))
-(define-record-type $uplink
- (make-uplink parent level)
- uplink?
- (parent uplink-parent)
- (level uplink-level))
-
-(define (visit-fun fun conts use-maps uplinks global?)
+(define-record-type $block
+ (%make-block scope scope-level preds succs idom dom-level loop-header)
+ block?
+ (scope block-scope set-block-scope!)
+ (scope-level block-scope-level set-block-scope-level!)
+ (preds block-preds set-block-preds!)
+ (succs block-succs set-block-succs!)
+ (idom block-idom set-block-idom!)
+ (dom-level block-dom-level set-block-dom-level!)
+ (loop-header block-loop-header set-block-loop-header!))
+
+(define (make-block scope scope-level)
+ (%make-block scope scope-level '() '() #f #f #f))
+
+(define (reverse-post-order k0 blocks)
+ (let ((order '())
+ (visited? (make-hash-table)))
+ (let visit ((k k0))
+ (hashq-set! visited? k #t)
+ (match (lookup-block k blocks)
+ ((and block ($ $block _ _ preds succs))
+ (for-each (lambda (k)
+ (unless (hashq-ref visited? k)
+ (visit k)))
+ succs)
+ (set! order (cons k order)))))
+ order))
+
+(define-inlinable (for-each/enumerate f l)
+ (fold (lambda (x n) (f x n) (1+ n)) 0 l))
+
+(define (convert-predecessors order blocks)
+ (let* ((len (length order))
+ (mapping (make-hash-table))
+ (preds-vec (make-vector len #f)))
+ (for-each/enumerate
+ (cut hashq-set! mapping <> <>)
+ order)
+ (for-each/enumerate
+ (lambda (k n)
+ (match (lookup-block k blocks)
+ (($ $block _ _ preds)
+ (vector-set! preds-vec n
+ ;; It's possible for a predecessor to not be in
+ ;; the mapping, if the predecessor is not
+ ;; reachable from the entry node.
+ (filter-map (cut hashq-ref mapping <>) preds)))))
+ order)
+ preds-vec))
+
+(define (finish-idoms order idoms blocks)
+ (let ((order (list->vector order))
+ (dom-levels (make-vector (vector-length idoms) #f)))
+ (define (compute-dom-level n)
+ (or (vector-ref dom-levels n)
+ (let ((dom-level (1+ (compute-dom-level (vector-ref idoms n)))))
+ (vector-set! dom-levels n dom-level)
+ dom-level)))
+ (vector-set! dom-levels 0 0)
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (let* ((k (vector-ref order n))
+ (idom (vector-ref idoms n))
+ (b (lookup-block k blocks)))
+ (set-block-idom! b (vector-ref order idom))
+ (set-block-dom-level! b (compute-dom-level n))
+ (lp (1+ n)))))))
+
+(define (compute-dominator-tree k blocks)
+ (let* ((order (reverse-post-order k blocks))
+ (preds (convert-predecessors order blocks))
+ (idoms (make-vector (vector-length preds) 0)))
+ (define (common-idom d0 d1)
+ ;; We exploit the fact that a reverse post-order is a topological
+ ;; sort, and so the idom of a node is always numerically less than
+ ;; the node itself.
+ (cond
+ ((= d0 d1) d0)
+ ((< d0 d1) (common-idom d0 (vector-ref idoms d1)))
+ (else (common-idom (vector-ref idoms d0) d1))))
+ (define (compute-idom preds)
+ (match preds
+ (() 0)
+ ((pred . preds)
+ (let lp ((idom pred) (preds preds))
+ (match preds
+ (() idom)
+ ((pred . preds)
+ (lp (common-idom idom pred) preds)))))))
+ ;; This is the iterative O(n^2) fixpoint algorithm, originally from
+ ;; Allen and Cocke ("Graph-theoretic constructs for program flow
+ ;; analysis", 1972). See the discussion in Cooper, Harvey, and
+ ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
+ (let iterate ((n 0) (changed? #f))
+ (cond
+ ((< n (vector-length preds))
+ (let ((idom (vector-ref idoms n))
+ (idom* (compute-idom (vector-ref preds n))))
+ (cond
+ ((eqv? idom idom*)
+ (iterate (1+ n) changed?))
+ (else
+ (vector-set! idoms n idom*)
+ (iterate (1+ n) #t)))))
+ (changed?
+ (iterate 0 #f))
+ (else
+ (finish-idoms order idoms blocks))))))
+
+(define (visit-fun fun conts blocks use-maps global?)
(define (add-def! sym def-k)
(unless def-k
(error "Term outside labelled continuation?"))
@@ -120,25 +225,34 @@
((and use-map ($ $use-map sym def uses))
(set-use-map-uses! use-map (cons use-k uses)))))
- (define (link-parent! k parent)
- (match (hashq-ref uplinks parent)
- (($ $uplink _ level)
- (hashq-set! uplinks k (make-uplink parent (1+ level))))))
+ (define* (declare-block! label cont parent
+ #:optional (level
+ (1+ (lookup-scope-level parent
blocks))))
+ (hashq-set! conts label cont)
+ (hashq-set! blocks label (make-block parent level)))
+
+ (define (link-blocks! pred succ)
+ (let ((pred-block (hashq-ref blocks pred))
+ (succ-block (hashq-ref blocks succ)))
+ (unless (and pred-block succ-block)
+ (error "internal error"))
+ (set-block-succs! pred-block (cons succ (block-succs pred-block)))
+ (set-block-preds! succ-block (cons pred (block-preds succ-block)))))
(define (visit exp exp-k)
(define (def! sym)
(add-def! sym exp-k))
(define (use! sym)
(add-use! sym exp-k))
+ (define (use-k! k)
+ (link-blocks! exp-k k))
(define (recur exp)
(visit exp exp-k))
(match exp
(($ $letk (($ $cont k src cont) ...) body)
;; Set up recursive environment before visiting cont bodies.
(for-each (lambda (cont k)
- (def! k)
- (hashq-set! conts k cont)
- (link-parent! k exp-k))
+ (declare-block! k cont exp-k))
cont k)
(for-each visit cont k)
(recur body))
@@ -148,21 +262,21 @@
(recur body))
(($ $kif kt kf)
- (use! kt)
- (use! kf))
+ (use-k! kt)
+ (use-k! kf))
(($ $ktrunc arity k)
- (use! k))
+ (use-k! k))
(($ $letrec names syms funs body)
(unless global?
(error "$letrec should not be present when building a local DFG"))
(for-each def! syms)
- (for-each (cut visit-fun <> conts use-maps uplinks global?) funs)
+ (for-each (cut visit-fun <> conts blocks use-maps global?) funs)
(visit body exp-k))
(($ $continue k exp)
- (use! k)
+ (use-k! k)
(match exp
(($ $var sym)
(use! sym))
@@ -179,11 +293,11 @@
(($ $prompt escape? tag handler)
(use! tag)
- (use! handler))
+ (use-k! handler))
(($ $fun)
(when global?
- (visit-fun exp conts use-maps uplinks global?)))
+ (visit-fun exp conts blocks use-maps global?)))
(_ #f)))))
@@ -192,44 +306,43 @@
($ $cont kentry src
(and entry
($ $kentry self ($ $cont ktail _ tail) clauses))))
- ;; Treat the fun continuation as its own parent.
- (add-def! kentry kentry)
+ (declare-block! kentry entry #f 0)
(add-def! self kentry)
- (hashq-set! uplinks kentry (make-uplink #f 0))
- (hashq-set! conts kentry entry)
- (add-def! ktail kentry)
- (hashq-set! conts ktail tail)
- (link-parent! ktail kentry)
+ (declare-block! ktail tail kentry)
(for-each
(match-lambda
(($ $cont kclause _
(and clause ($ $kclause arity ($ $cont kbody _ body))))
- (add-def! kclause kentry)
- (hashq-set! conts kclause clause)
- (link-parent! kclause kentry)
+ (declare-block! kclause clause kentry)
+ (link-blocks! kentry kclause)
- (add-def! kbody kclause)
- (hashq-set! conts kbody body)
- (link-parent! kbody kclause)
+ (declare-block! kbody body kclause)
+ (link-blocks! kclause kbody)
(visit body kbody)))
- clauses))))
+ clauses)
+
+ (compute-dominator-tree kentry blocks))))
(define* (compute-dfg fun #:key (global? #t))
(let* ((conts (make-hash-table))
- (use-maps (make-hash-table))
- (uplinks (make-hash-table)))
- (visit-fun fun conts use-maps uplinks global?)
- (make-dfg conts use-maps uplinks)))
+ (blocks (make-hash-table))
+ (use-maps (make-hash-table)))
+ (visit-fun fun conts blocks use-maps global?)
+ (make-dfg conts blocks use-maps)))
-(define (lookup-uplink k uplinks)
- (let ((res (hashq-ref uplinks k)))
+(define (lookup-block k blocks)
+ (let ((res (hashq-ref blocks k)))
(unless res
- (error "Unknown continuation!" k (hash-fold acons '() uplinks)))
+ (error "Unknown continuation!" k (hash-fold acons '() blocks)))
res))
+(define (lookup-scope-level k blocks)
+ (match (lookup-block k blocks)
+ (($ $block _ scope-level) scope-level)))
+
(define (lookup-use-map sym use-maps)
(let ((res (hashq-ref use-maps sym)))
(unless res
@@ -238,20 +351,28 @@
(define (lookup-def sym dfg)
(match dfg
- (($ $dfg conts use-maps uplinks)
+ (($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
def)))))
(define (lookup-uses sym dfg)
(match dfg
- (($ $dfg conts use-maps uplinks)
+ (($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
uses)))))
+(define (lookup-predecessors k dfg)
+ (match (lookup-block k (dfg-blocks dfg))
+ (($ $block _ _ preds succs) preds)))
+
+(define (lookup-successors k dfg)
+ (match (lookup-block k (dfg-blocks dfg))
+ (($ $block _ _ preds succs) succs)))
+
(define (find-defining-term sym dfg)
- (match (lookup-uses (lookup-def sym dfg) dfg)
+ (match (lookup-predecessors (lookup-def sym dfg) dfg)
((def-exp-k)
(lookup-cont def-exp-k (dfg-cont-table dfg)))
(else #f)))
@@ -274,6 +395,7 @@
(match (find-defining-term sym dfg)
(#f #f)
(($ $ktrunc) #f)
+ (($ $kclause) #f)
(term (find-expression term))))
(define (find-constant-value sym dfg)
@@ -292,7 +414,7 @@
(($ $letk conts body) (find-exp body))
(else term)))
(match dfg
- (($ $dfg conts use-maps uplinks)
+ (($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map _ def uses)
(or-map
@@ -315,45 +437,50 @@
(_ #t)))
uses))))))
-(define (continuation-scope-contains? parent-k k uplinks)
- (match (lookup-uplink parent-k uplinks)
- (($ $uplink _ parent-level)
- (let lp ((k k))
- (or (eq? parent-k k)
- (match (lookup-uplink k uplinks)
- (($ $uplink parent level)
- (and (< parent-level level)
- (lp parent)))))))))
-
-(define (lift-definition! k parent-k dfg)
+(define (continuation-scope-contains? scope-k k blocks)
+ (let ((scope-level (lookup-scope-level scope-k blocks)))
+ (let lp ((k k))
+ (or (eq? scope-k k)
+ (match (lookup-block k blocks)
+ (($ $block scope level)
+ (and (< scope-level level)
+ (lp scope))))))))
+
+;; FIXME: Splice preds, succs, dom tree.
+(define (lift-definition! k scope-k dfg)
(match dfg
- (($ $dfg conts use-maps uplinks)
- (match (lookup-uplink parent-k uplinks)
- (($ $uplink parent level)
- (hashq-set! uplinks k
- (make-uplink parent-k (1+ level)))
- ;; Lift definitions of all conts in K.
- (let lp ((cont (lookup-cont k conts)))
- (match cont
- (($ $letk (($ $cont kid) ...) body)
- (for-each (cut lift-definition! <> k dfg) kid)
- (lp body))
- (($ $letrec names syms funs body)
- (lp body))
- (_ #t))))))))
-
-(define (variable-bound-in? var k dfg)
+ (($ $dfg conts blocks use-maps)
+ (let ((scope-level (1+ (lookup-scope-level scope-k blocks))))
+ ;; Fix parent scope link of K.
+ (match (lookup-block k blocks)
+ ((and block ($ $block))
+ (set-block-scope! block scope-k)))
+ ;; Fix up scope levels of K and all contained scopes.
+ (let update-levels! ((k k) (level scope-level))
+ (match (lookup-block k blocks)
+ ((and block ($ $block))
+ (set-block-scope-level! block scope-level)))
+ (let lp ((cont (lookup-cont k conts)))
+ (match cont
+ (($ $letk (($ $cont kid) ...) body)
+ (for-each (cut update-levels! <> (1+ scope-level)) kid)
+ (lp body))
+ (($ $letrec names syms funs body)
+ (lp body))
+ (_ #t))))))))
+
+(define (continuation-bound-in? k use-k dfg)
(match dfg
- (($ $dfg conts use-maps uplinks)
- (match (lookup-use-map var use-maps)
- (($ $use-map sym def uses)
- (continuation-scope-contains? def k uplinks))))))
+ (($ $dfg conts blocks use-maps)
+ (match (lookup-block k blocks)
+ (($ $block def-k)
+ (continuation-scope-contains? def-k use-k blocks))))))
(define (variable-free-in? var k dfg)
(match dfg
- (($ $dfg conts use-maps uplinks)
+ (($ $dfg conts blocks use-maps)
(or-map (lambda (use)
- (continuation-scope-contains? k use uplinks))
+ (continuation-scope-contains? k use blocks))
(match (lookup-use-map var use-maps)
(($ $use-map sym def uses)
uses))))))
@@ -366,59 +493,52 @@
;; relationship. See
;; http://mlton.org/pipermail/mlton/2003-January/023054.html for a
;; deeper discussion.
-(define (conservatively-dominates? k1 k2 uplinks)
- (continuation-scope-contains? k1 k2 uplinks))
+(define (conservatively-dominates? k1 k2 blocks)
+ (continuation-scope-contains? k1 k2 blocks))
(define (dead-after-def? sym dfg)
(match dfg
- (($ $dfg conts use-maps uplinks)
+ (($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
(null? uses))))))
(define (dead-after-use? sym use-k dfg)
(match dfg
- (($ $dfg conts use-maps uplinks)
+ (($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
;; If all other uses dominate this use, it is now dead. There
;; are other ways for it to be dead, but this is an
;; approximation. A better check would be if the successor
;; post-dominates all uses.
- (and-map (cut conservatively-dominates? <> use-k uplinks)
+ (and-map (cut conservatively-dominates? <> use-k blocks)
uses))))))
;; A continuation is a "branch" if all of its predecessors are $kif
;; continuations.
(define (branch? k dfg)
- (match dfg
- (($ $dfg conts use-maps uplinks)
- (match (lookup-use-map k use-maps)
- (($ $use-map sym def uses)
- (and (not (null? uses))
- (and-map (lambda (k)
- (match (lookup-cont k conts)
- (($ $kif) #t)
- (_ #f)))
- uses)))))))
+ (let ((preds (lookup-predecessors k dfg)))
+ (and (not (null? preds))
+ (and-map (lambda (k)
+ (match (lookup-cont k (dfg-cont-table dfg))
+ (($ $kif) #t)
+ (_ #f)))
+ preds))))
(define (find-other-branches k dfg)
- (match dfg
- (($ $dfg conts use-maps uplinks)
- (match (lookup-use-map k use-maps)
- (($ $use-map sym def (uses ..1))
- (map (lambda (kif)
- (match (lookup-cont kif conts)
- (($ $kif (? (cut eq? <> k)) kf)
- kf)
- (($ $kif kt (? (cut eq? <> k)))
- kt)
- (_ (error "Not all predecessors are branches"))))
- uses))))))
+ (map (lambda (kif)
+ (match (lookup-cont kif (dfg-cont-table dfg))
+ (($ $kif (? (cut eq? <> k)) kf)
+ kf)
+ (($ $kif kt (? (cut eq? <> k)))
+ kt)
+ (_ (error "Not all predecessors are branches"))))
+ (lookup-predecessors k dfg)))
(define (dead-after-branch? sym branch other-branches dfg)
(match dfg
- (($ $dfg conts use-maps uplinks)
+ (($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
(and-map
@@ -426,15 +546,15 @@
;; A symbol is dead after a branch if at least one of the
;; other branches dominates a use of the symbol, and all
;; other uses of the symbol dominate the test.
- (if (or-map (cut conservatively-dominates? <> use-k uplinks)
+ (if (or-map (cut conservatively-dominates? <> use-k blocks)
other-branches)
- (not (conservatively-dominates? branch use-k uplinks))
- (conservatively-dominates? use-k branch uplinks)))
+ (not (conservatively-dominates? branch use-k blocks))
+ (conservatively-dominates? use-k branch blocks)))
uses))))))
(define (lookup-bound-syms k dfg)
(match dfg
- (($ $dfg conts use-maps uplinks)
+ (($ $dfg conts blocks use-maps)
(match (lookup-cont k conts)
(($ $kargs names syms body)
syms)))))
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 3d35039..f3c0161 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1350,26 +1350,48 @@ top-level bindings from ENV and return the resulting
expression."
;; todo: handle the more complex cases
(let* ((nargs (length orig-args))
(nreq (length req))
- (nopt (if opt (length opt) 0))
+ (opt (or opt '()))
+ (rest (if rest (list rest) '()))
+ (nopt (length opt))
(key (source-expression proc)))
(define (inlined-call)
- (make-let src
- (append req
- (or opt '())
- (if rest (list rest) '()))
- gensyms
- (if (> nargs (+ nreq nopt))
- (append (list-head orig-args (+ nreq nopt))
- (list
- (make-primcall
- #f 'list
- (drop orig-args (+ nreq nopt)))))
- (append orig-args
- (drop inits (- nargs nreq))
- (if rest
- (list (make-const #f '()))
- '())))
- body))
+ (let ((req-vals (list-head orig-args nreq))
+ (opt-vals (let lp ((args (drop orig-args nreq))
+ (inits inits)
+ (out '()))
+ (match inits
+ (() (reverse out))
+ ((init . inits)
+ (match args
+ (()
+ (lp '() inits (cons init out)))
+ ((arg . args)
+ (lp args inits (cons arg out))))))))
+ (rest-vals (cond
+ ((> nargs (+ nreq nopt))
+ (list (make-primcall
+ #f 'list
+ (drop orig-args (+ nreq nopt)))))
+ (rest (list (make-const #f '())))
+ (else '()))))
+ (if (>= nargs (+ nreq nopt))
+ (make-let src
+ (append req opt rest)
+ gensyms
+ (append req-vals opt-vals rest-vals)
+ body)
+ ;; The required argument values are in the scope
+ ;; of the optional argument initializers.
+ (make-let src
+ (append req rest)
+ (append (list-head gensyms nreq)
+ (last-pair gensyms))
+ (append req-vals rest-vals)
+ (make-let src
+ opt
+ (list-head (drop gensyms nreq) nopt)
+ opt-vals
+ body)))))
(cond
((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 34abc7e..6b0ac48 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1663,7 +1663,7 @@ it will be added to the GC roots at runtime."
;; Now write the statement program.
(let ()
(define (extended-op opcode payload-len)
- (put-u8 line-port 0) ; extended op
+ (put-u8 line-port 0) ; extended op
(put-uleb128 line-port (1+ payload-len)) ; payload-len + opcode
(put-uleb128 line-port opcode))
(define (set-address sym)
@@ -1685,7 +1685,7 @@ it will be added to the GC roots at runtime."
(put-u64 line-port 0))))
(define (end-sequence pc)
(let ((pc-inc (- (asm-pos asm) pc)))
- (put-u8 line-port 2) ; advance-pc
+ (put-u8 line-port 2) ; advance-pc
(put-uleb128 line-port pc-inc))
(extended-op 1 0))
(define (advance-pc pc-inc line-inc)
@@ -1718,7 +1718,12 @@ it will be added to the GC roots at runtime."
(let lp ((in out) (pc 0) (file 1) (line 1) (col 0))
(match in
- (() (end-sequence pc))
+ (()
+ (when (null? out)
+ ;; There was no source info in the first place. Set
+ ;; file register to 0 before adding final row.
+ (set-file 0))
+ (end-sequence pc))
(((pc* file* line* col*) . in*)
(cond
((and (eqv? file file*) (eqv? line line*) (eqv? col col*))
diff --git a/module/system/vm/dwarf.scm b/module/system/vm/dwarf.scm
index 352cb22..da730a6 100644
--- a/module/system/vm/dwarf.scm
+++ b/module/system/vm/dwarf.scm
@@ -1397,6 +1397,9 @@
(scan pos* pc* file* line* col*))
((= pc* target-pc)
(finish pos* pc* file* line* col*))
+ ((zero? pc)
+ ;; We scanned from the beginning didn't find any info.
+ (values #f #f #f #f))
(else
(finish pos pc file line col))))))
(let ((pos (lregs-pos regs))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 270224e..0949ddf 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1279,4 +1279,12 @@
(pass-if-peval
(call-with-values foo (lambda (x) (bar x)))
(let (x) (_) ((call (toplevel foo)))
- (call (toplevel bar) (lexical x _)))))
+ (call (toplevel bar) (lexical x _))))
+
+ (pass-if-peval
+ ((lambda (foo)
+ (define* (bar a #:optional (b (1+ a)))
+ (list a b))
+ (bar 1))
+ 1)
+ (primcall list (const 1) (const 2))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-226-g3aee6cf,
Andy Wingo <=