[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] [PATCH] better line-number tracking
|
From: |
Felix |
|
Subject: |
[Chicken-hackers] [PATCH] better line-number tracking |
|
Date: |
Mon, 27 Feb 2012 10:36:04 +0100 (CET) |
The attached patch adds various enhancements for keeping line-number
information. First during canonicalization, intermediate expressions
are re-decorated with line-info. If no line-number info for an
expression (lists that have a symbol as their first element) is
available, the one of the next outer expression is used. This will
report line-numbers correctly for code produced by syntax-expansions
in scrutinizer messages and warnings. "compiler-typecase" does now
keep line-number info to ensure errors generated by it will provide
some hint at the exact location (it would be quite unhelpful
otherwise). Debug-output for contraction and inlining will now report
the line number of the call (if available).
The time spent during the canonicalization pass in the compiler is now
roughly doubled, at least for the few tests I made. Note that this is
only in the compiler, not csi.
This is quite a large patch, but mostly changes every call to the "walk"
procedure in the canonicalizer.
cheers,
felix
>From 129959e8b28a8d1373f91ed5ef574d4458d469ec Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Mon, 27 Feb 2012 10:24:22 +0100
Subject: [PATCH] Line-number tracking enhancements.
Squashed commit of the following:
commit 5bab46186c52d3983d97eeebb804f69015d0a4ff
Author: felix <address@hidden>
Date: Fri Jan 27 09:13:03 2012 +0100
use line-number info in debug-messages for inlining
commit 99f7cc9b482d9130824ecb1b6b5b32a5fb96e366
Author: felix <address@hidden>
Date: Tue Jan 24 12:13:35 2012 +0100
use line-number info of outer-expression if no other is available; updated
expected scrutinizer output
commit bf40b1fb70acc2c4d7893209ea2711689773fb34
Author: felix <address@hidden>
Date: Tue Jan 24 12:12:59 2012 +0100
use the same output-format for line-numbers in scrutinizer-messages as used
in other places
commit e0e3409a889ea40e775044fa77f6b21e20699dda
Author: felix <address@hidden>
Date: Tue Jan 24 11:57:40 2012 +0100
update ln-db for intermediate calls to ##sys#expand in canonicalization
pass of compiler; use available ln-information when canonicalizing
##core#typecase
commit 34ced5125133b074dc5b5bc2ba57802a964a436c
Author: felix <address@hidden>
Date: Tue Jan 24 08:26:56 2012 +0100
failure-message for compiler-typecase shows line-number if available
---
chicken-syntax.scm | 4 +-
compiler-namespace.scm | 1 +
compiler.scm | 147 +++++++++++++++++++++++----------------------
eval.scm | 2 +-
optimizer.scm | 36 ++++++------
scrutinizer.scm | 14 +++--
support.scm | 16 ++++-
tests/scrutiny-2.expected | 50 ++++++++--------
tests/scrutiny.expected | 30 +++++-----
9 files changed, 158 insertions(+), 142 deletions(-)
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 7c4ab18..bed542e 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1274,9 +1274,11 @@
(##sys#er-transformer
(lambda (x r c)
(##sys#check-syntax 'compiler-typecase x '(_ _ . #((_ . #(_ 1)) 1)))
- (let ((var (gensym)))
+ (let ((var (gensym))
+ (ln (get-line-number x)))
`(##core#let ((,var ,(cadr x)))
(##core#typecase
+ ,ln
,var ; must be variable (see: CPS transform)
,@(map (lambda (clause)
(list (car clause) `(##core#begin ,@(cdr clause))))
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 89c7e7e..7351f81 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -42,6 +42,7 @@
build-node-graph
c-ify-string
callback-names
+ call-info
canonicalize-list-of-type
canonicalize-begin-body
canonicalize-expression
diff --git a/compiler.scm b/compiler.scm
index 3df1865..0917cec 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -147,7 +147,7 @@
; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
; (##core#let-module-alias ((<alias> <name>) ...) <body>)
; (##core#the <type> <strict?> <exp>)
-; (##core#typecase <exp> (<type> <body>) ... [(else <body>)])
+; (##core#typecase <info> <exp> (<type> <body>) ... [(else <body>)])
; (<exp> {<exp>})
; - Core language:
@@ -175,7 +175,7 @@
; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f>
<exp>...]
; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>}
<exp>]
; [##core#the {<type> <strict>} <exp>]
-; [##core#typecase {(<type> ...)} <exp> <body1> ... [<elsebody>]]
+; [##core#typecase {<info> (<type> ...)} <exp> <body1> ... [<elsebody>]]
; - Closure converted/prepared language:
;
@@ -436,9 +436,9 @@
(d `(RESOLVE-VARIABLE: ,x0 ,x ,(map (lambda (x) (car x)) se)))
(cond ((not (symbol? x)) x0) ; syntax?
[(and constants-used (##sys#hash-table-ref constant-table x))
- => (lambda (val) (walk (car val) e se dest ldest h)) ]
+ => (lambda (val) (walk (car val) e se dest ldest h #f)) ]
[(and inline-table-used (##sys#hash-table-ref inline-table x))
- => (lambda (val) (walk val e se dest ldest h)) ]
+ => (lambda (val) (walk val e se dest ldest h #f)) ]
[(assq x foreign-variables)
=> (lambda (fv)
(let* ([t (second fv)]
@@ -448,7 +448,7 @@
(foreign-type-convert-result
(finish-foreign-result ft body)
t)
- e se dest ldest h)))]
+ e se dest ldest h #f)))]
[(assq x location-pointer-map)
=> (lambda (a)
(let* ([t (third a)]
@@ -458,7 +458,7 @@
(foreign-type-convert-result
(finish-foreign-result ft body)
t)
- e se dest ldest h))) ]
+ e se dest ldest h #f))) ]
((##sys#get x '##core#primitive))
((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global
(else x))))
@@ -486,7 +486,7 @@
(for-each pretty-print imps)
(print "\n;; END OF FILE"))))) ) )
- (define (walk x e se dest ldest h)
+ (define (walk x e se dest ldest h outer-ln)
(cond ((symbol? x)
(cond ((keyword? x) `(quote ,x))
((memq x unlikely-variables)
@@ -498,7 +498,7 @@
`(quote ,x)
(##sys#syntax-error/context "illegal atomic form" x)))
((symbol? (car x))
- (let ([ln (get-line x)])
+ (let ((ln (or (get-line x) outer-ln)))
(emit-syntax-trace-info x #f)
(unless (proper-list? x)
(if ln
@@ -508,24 +508,24 @@
(let* ((name0 (lookup (car x) se))
(name (or (and (symbol? name0) (##sys#get name0
'##core#primitive)) name0))
(xexpanded (##sys#expand x se compiler-syntax-enabled)))
+ (when ln (update-line-number-database! xexpanded ln))
(cond ((not (eq? x xexpanded))
- (walk xexpanded e se dest ldest h))
+ (walk xexpanded e se dest ldest h ln))
[(and inline-table-used (##sys#hash-table-ref inline-table
name))
=> (lambda (val)
- (walk (cons val (cdr x)) e se dest ldest h)) ]
+ (walk (cons val (cdr x)) e se dest ldest h ln)) ]
[else
- (when ln (update-line-number-database! xexpanded ln))
(case name
((##core#if)
`(if
- ,(walk (cadr x) e se #f #f h)
- ,(walk (caddr x) e se #f #f h)
+ ,(walk (cadr x) e se #f #f h ln)
+ ,(walk (caddr x) e se #f #f h ln)
,(if (null? (cdddr x))
'(##core#undefined)
- (walk (cadddr x) e se #f #f h) ) ) )
+ (walk (cadddr x) e se #f #f h ln) ) ) )
((##core#syntax ##core#quote)
`(quote ,(##sys#strip-syntax (cadr x))))
@@ -533,21 +533,22 @@
((##core#check)
(if unsafe
''#t
- (walk (cadr x) e se dest ldest h) ) )
+ (walk (cadr x) e se dest ldest h ln) ) )
((##core#the)
`(##core#the
,(##sys#strip-syntax (cadr x))
,(caddr x)
- ,(walk (cadddr x) e se dest ldest h)))
+ ,(walk (cadddr x) e se dest ldest h ln)))
((##core#typecase)
`(##core#typecase
- ,(walk (cadr x) e se #f #f h)
+ ,(or ln (cadr x))
+ ,(walk (caddr x) e se #f #f h ln)
,@(map (lambda (cl)
(list (##sys#strip-syntax (car cl))
- (walk (cadr cl) e se dest ldest h)))
- (cddr x))))
+ (walk (cadr cl) e se dest ldest h
ln)))
+ (cdddr x))))
((##core#immutable)
(let ((c (cadadr x)))
@@ -568,7 +569,7 @@
((##core#inline_loc_ref)
`(##core#inline_loc_ref
,(##sys#strip-syntax (cadr x))
- ,(walk (caddr x) e se dest ldest h)))
+ ,(walk (caddr x) e se dest ldest h ln)))
((##core#require-for-syntax)
(let ([ids (map eval (cdr x))])
@@ -598,7 +599,7 @@
(warning
(sprintf "extension `~A' is currently
not installed" realid)))
`(##core#begin ,exp ,(loop (cdr ids))) )
) ) )
- e se dest ldest h) ) )
+ e se dest ldest h ln) ) )
((##core#let)
(let* ((bindings (cadr x))
@@ -608,12 +609,12 @@
(set-real-names! aliases vars)
`(let
,(map (lambda (alias b)
- (list alias (walk (cadr b) e se (car b) #t
h)) )
+ (list alias (walk (cadr b) e se (car b) #t
h ln)) )
aliases bindings)
,(walk (##sys#canonicalize-body
(cddr x) se2 compiler-syntax-enabled)
(append aliases e)
- se2 dest ldest h) ) ) )
+ se2 dest ldest h ln) ) ) )
((##core#letrec)
(let ((bindings (cadr x))
@@ -627,7 +628,7 @@
`(##core#set! ,(car b) ,(cadr b)))
bindings)
(##core#let () ,@body) )
- e se dest ldest h)))
+ e se dest ldest h ln)))
((##core#lambda)
(let ((llist (cadr x))
@@ -644,7 +645,7 @@
(se2 (##sys#extend-se se vars aliases))
(body0 (##sys#canonicalize-body
obody se2 compiler-syntax-enabled))
- (body (walk body0 (append aliases e) se2
#f #f dest))
+ (body (walk body0 (append aliases e) se2
#f #f dest ln))
(llist2
(build-lambda-list
aliases argc
@@ -681,7 +682,7 @@
(walk
(##sys#canonicalize-body (cddr x) se2
compiler-syntax-enabled)
e se2
- dest ldest h) ) )
+ dest ldest h ln) ) )
((##core#letrec-syntax)
(let* ((ms (map (lambda (b)
@@ -699,7 +700,7 @@
ms)
(walk
(##sys#canonicalize-body (cddr x) se2
compiler-syntax-enabled)
- e se2 dest ldest h)))
+ e se2 dest ldest h ln)))
((##core#define-syntax)
(##sys#check-syntax
@@ -724,7 +725,7 @@
',var
(##sys#current-environment) ,body) ;XXX
possibly wrong se?
'(##core#undefined) )
- e se dest ldest h)) )
+ e se dest ldest h ln)) )
((##core#define-compiler-syntax)
(let* ((var (cadr x))
@@ -756,7 +757,7 @@
',var)
(##sys#current-environment))))
'(##core#undefined) )
- e se dest ldest h)))
+ e se dest ldest h ln)))
((##core#let-compiler-syntax)
(let ((bs (map
@@ -783,7 +784,7 @@
(walk
(##sys#canonicalize-body
(cddr x) se compiler-syntax-enabled)
- e se dest ldest h) )
+ e se dest ldest h ln) )
(lambda ()
(for-each
(lambda (b)
@@ -797,7 +798,7 @@
`(##core#begin
,@(fluid-let ((##sys#default-read-info-hook
read-info-hook))
(##sys#include-forms-from-file (cadr x))))
- e se dest ldest h))
+ e se dest ldest h ln))
((##core#let-module-alias)
(##sys#with-module-aliases
@@ -806,7 +807,7 @@
(##sys#strip-syntax b))
(cadr x))
(lambda ()
- (walk `(##core#begin ,@(cddr x)) e se dest ldest
h))))
+ (walk `(##core#begin ,@(cddr x)) e se dest ldest h
ln))))
((##core#module)
(let* ((x (##sys#strip-syntax x))
@@ -875,7 +876,7 @@
(car body)
e ;?
(##sys#current-environment)
- #f #f h)
+ #f #f h ln)
xs))))))))))
(let ((body
(canonicalize-begin-body
@@ -888,7 +889,7 @@
(walk
x
e ;?
- (##sys#current-meta-environment) #f
#f h) )
+ (##sys#current-meta-environment) #f
#f h ln) )
mreg))
body))))
(do ((cs compiler-syntax (cdr cs)))
@@ -906,7 +907,7 @@
(walk
(##sys#canonicalize-body obody se2
compiler-syntax-enabled)
(append aliases e)
- se2 #f #f dest) ] )
+ se2 #f #f dest ln) ] )
(set-real-names! aliases vars)
`(##core#lambda ,aliases ,body) ) )
@@ -928,7 +929,7 @@
(##core#inline_update
(,(third fv) ,type)
,(foreign-type-check tmp type) )
)
- e se #f #f h))))
+ e se #f #f h ln))))
((assq var location-pointer-map)
=> (lambda (a)
(let* ([type (third a)]
@@ -939,7 +940,7 @@
(,type)
,(second a)
,(foreign-type-check tmp type) ) )
- e se #f #f h))))
+ e se #f #f h ln))))
(else
(unless (memq var e) ; global?
(set! var (or (##sys#get var
'##core#primitive)
@@ -958,29 +959,30 @@
(##sys#notice "assignment to imported
value binding" var)))
(when (keyword? var)
(warning (sprintf "assignment to keyword
`~S'" var) ))
- `(set! ,var ,(walk val e se var0 (memq var e)
h))))))
+ `(set! ,var ,(walk val e se var0 (memq var e)
h ln))))))
((##core#inline)
- `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk
(cddr x) e se h)))
+ `(##core#inline
+ ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se h
ln)))
((##core#inline_allocate)
`(##core#inline_allocate
,(map (cut unquotify <> se) (second x))
- ,@(mapwalk (cddr x) e se h)))
+ ,@(mapwalk (cddr x) e se h ln)))
((##core#inline_update)
- `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se
#f #f h)) )
+ `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se
#f #f h ln)) )
((##core#inline_loc_update)
`(##core#inline_loc_update
,(cadr x)
- ,(walk (caddr x) e se #f #f h)
- ,(walk (cadddr x) e se #f #f h)) )
+ ,(walk (caddr x) e se #f #f h ln)
+ ,(walk (cadddr x) e se #f #f h ln)) )
((##core#compiletimetoo ##core#elaborationtimetoo)
(let ((exp (cadr x)))
(##sys#eval/meta exp)
- (walk exp e se dest #f h) ) )
+ (walk exp e se dest #f h ln) ) )
((##core#compiletimeonly ##core#elaborationtimeonly)
(##sys#eval/meta (cadr x))
@@ -993,24 +995,24 @@
(let ([x (car xs)]
[r (cdr xs)] )
(if (null? r)
- (list (walk x e se dest ldest h))
- (cons (walk x e se #f #f h) (fold r)) ) )
) )
+ (list (walk x e se dest ldest h ln))
+ (cons (walk x e se #f #f h ln) (fold r))
) ) ) )
'(##core#undefined) ) )
((##core#foreign-lambda)
- (walk (expand-foreign-lambda x #f) e se dest ldest h) )
+ (walk (expand-foreign-lambda x #f) e se dest ldest h
ln) )
((##core#foreign-safe-lambda)
- (walk (expand-foreign-lambda x #t) e se dest ldest h) )
+ (walk (expand-foreign-lambda x #t) e se dest ldest h
ln) )
((##core#foreign-lambda*)
- (walk (expand-foreign-lambda* x #f) e se dest ldest h)
)
+ (walk (expand-foreign-lambda* x #f) e se dest ldest h
ln) )
((##core#foreign-safe-lambda*)
- (walk (expand-foreign-lambda* x #t) e se dest ldest h)
)
+ (walk (expand-foreign-lambda* x #t) e se dest ldest h
ln) )
((##core#foreign-primitive)
- (walk (expand-foreign-primitive x) e se dest ldest h) )
+ (walk (expand-foreign-primitive x) e se dest ldest h
ln) )
((##core#define-foreign-variable)
(let* ([var (##sys#strip-syntax (second x))]
@@ -1044,7 +1046,7 @@
(define
,ret
,(if (pair? (cdr conv)) (second conv)
'##sys#values)) )
- e se dest ldest h) ) ]
+ e se dest ldest h ln) ) ]
[else
(##sys#hash-table-set! foreign-type-table
name type)
'(##core#undefined) ] ) ) )
@@ -1087,7 +1089,7 @@
'() )
,(if init (fifth x) (fourth x)) ) )
e (alist-cons var alias se)
- dest ldest h) ) )
+ dest ldest h ln) ) )
((##core#define-inline)
(let* ((name (second x))
@@ -1121,7 +1123,7 @@
(hide-variable var)
(mark-variable var '##compiler#constant)
(mark-variable var '##compiler#always-bound)
- (walk `(define ,var ',val) e se #f #f h) ) )
+ (walk `(define ,var ',val) e se #f #f h ln)
) )
(else
(quit "invalid compile-time value for named
constant `~S'"
name)))))
@@ -1135,7 +1137,7 @@
(lambda (id)
(memq (lookup id se) e))))
(cdr x) ) )
- e '() #f #f h) )
+ e '() #f #f h ln) )
((##core#foreign-callback-wrapper)
(let-values ([(args lam) (split-at (cdr x) 4)])
@@ -1157,7 +1159,7 @@
"non-matching or invalid argument list to
foreign callback-wrapper"
vars atypes) )
`(##core#foreign-callback-wrapper
- ,@(mapwalk args e se h)
+ ,@(mapwalk args e se h ln)
,(walk `(##core#lambda
,vars
(##core#let
@@ -1214,7 +1216,7 @@
(##sys#make-c-string r
',name)) ) ) )
(else (cddr lam)) ) )
rtype) ) )
- e se #f #f h) ) ) ) )
+ e se #f #f h ln) ) ) ) )
((##core#location)
(let ([sym (cadr x)])
@@ -1223,23 +1225,23 @@
=> (lambda (a)
(walk
`(##sys#make-locative ,(second a) 0
#f 'location)
- e se #f #f h) ) ]
+ e se #f #f h ln) ) ]
[(assq sym external-to-pointer)
- => (lambda (a) (walk (cdr a) e se #f #f
h)) ]
+ => (lambda (a) (walk (cdr a) e se #f #f h
ln)) ]
[(assq sym callback-names)
`(##core#inline_ref (,(symbol->string
sym) c-pointer)) ]
[else
(walk
`(##sys#make-locative ,sym 0 #f
'location)
- e se #f #f h) ] )
+ e se #f #f h ln) ] )
(walk
`(##sys#make-locative ,sym 0 #f 'location)
- e se #f #f h) ) ) )
+ e se #f #f h ln) ) ) )
(else
(let* ((x2 (fluid-let ((##sys#syntax-context
(cons name
##sys#syntax-context)))
- (mapwalk x e se h)))
+ (mapwalk x e se h ln)))
(head2 (car x2))
(old (##sys#hash-table-ref
line-number-database-2 head2)) )
(when ln
@@ -1255,7 +1257,7 @@
((constant? (car x))
(emit-syntax-trace-info x #f)
(warning "literal in operator position" x)
- (mapwalk x e se h) )
+ (mapwalk x e se h outer-ln) )
(else
(emit-syntax-trace-info x #f)
@@ -1264,10 +1266,10 @@
`(##core#let
((,tmp ,(car x)))
(,tmp ,@(cdr x)))
- e se dest ldest h)))))
+ e se dest ldest h outer-ln)))))
- (define (mapwalk xs e se h)
- (map (lambda (x) (walk x e se #f #f h)) xs) )
+ (define (mapwalk xs e se h ln)
+ (map (lambda (x) (walk x e se #f #f h ln)) xs) )
(when (memq 'c debugging-chicken) (newline) (pretty-print exp))
(##sys#clear-trace-buffer)
@@ -1280,7 +1282,7 @@
,(begin
(set! extended-bindings (append internal-bindings extended-bindings))
exp) )
- '() (##sys#current-environment) #f #f #f) ) )
+ '() (##sys#current-environment) #f #f #f #f) ) )
(define (process-declaration spec se local?)
@@ -1635,17 +1637,16 @@
(define (update-line-number-database! exp ln)
(define (mapupdate xs)
(let loop ((xs xs))
- (if (pair? xs)
- (begin
- (walk (car xs))
- (loop (cdr xs)) ) ) ) )
+ (when (pair? xs)
+ (walk (car xs))
+ (loop (cdr xs)) ) ) )
(define (walk x)
(cond ((not-pair? x))
((symbol? (car x))
(let* ((name (car x))
(old (or (##sys#hash-table-ref ##sys#line-number-database
name) '())) )
- (if (not (assq x old))
- (##sys#hash-table-set! ##sys#line-number-database name
(alist-cons x ln old)) )
+ (unless (assq x old)
+ (##sys#hash-table-set! ##sys#line-number-database name
(alist-cons x ln old)) )
(mapupdate (cdr x)) ) )
(else (mapupdate x)) ) )
(walk exp) )
diff --git a/eval.scm b/eval.scm
index a2fdb5c..779c230 100644
--- a/eval.scm
+++ b/eval.scm
@@ -715,7 +715,7 @@
((##core#typecase)
;; drops exp and requires "else" clause
- (cond ((assq 'else (##sys#strip-syntax (cddr x))) =>
+ (cond ((assq 'else (##sys#strip-syntax (cdddr x))) =>
(lambda (cl)
(compile (cadr cl) e h tf cntr se)))
(else
diff --git a/optimizer.scm b/optimizer.scm
index b470198..b4c39f7 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -301,22 +301,23 @@
(walk-generic n class params subs fids '() #f))
((##core#call)
- (let* ([fun (car subs)]
- [funclass (node-class fun)] )
+ (let* ((fun (car subs))
+ (funclass (node-class fun)))
(case funclass
[(##core#variable)
;; Call to named procedure:
- (let* ([var (first (node-parameters fun))]
- [lval (and (not (test var 'unknown))
+ (let* ((var (first (node-parameters fun)))
+ (info (call-info params var))
+ (lval (and (not (test var 'unknown))
(or (test var 'value)
- (test var 'local-value)))]
- [args (cdr subs)] )
+ (test var 'local-value))))
+ (args (cdr subs)) )
(cond ((test var 'contractable)
;; only called once
(let* ([lparams (node-parameters lval)]
[llist (third lparams)] )
(check-signature var args llist)
- (debugging 'o "contracted procedure" var)
+ (debugging 'o "contracted procedure" info)
(touch)
(for-each (cut put! db <> 'inline-target #t) fids)
(walk
@@ -338,11 +339,10 @@
(not (test (car llist)
'assigned)))))
((not (any (cut
expression-has-side-effects? <> db)
(cdr args) ))))
- (let ((info (and (pair? (cdr params)) (second
params))))
- (debugging
- 'o
- "removed call to pure procedure with unused
result"
- (or (source-info->string info) var)))
+ (debugging
+ 'o
+ "removed call to pure procedure with unused
result"
+ info)
(make-node
'##core#call (list #t)
(list k (make-node '##core#undefined '() '()))
) )
@@ -371,17 +371,17 @@
(if external
"global inlining"
"inlining")
- var ifid (fourth lparams))
+ info ifid (fourth lparams))
(for-each (cut put! db <> 'inline-target
#t) fids)
(check-signature var args llist)
- (debugging 'o "inlining procedure" var)
+ (debugging 'o "inlining procedure" info)
(call/cc
(lambda (return)
(define (cfk cvar)
(debugging
'i
"not inlining procedure because it
refers to contractable"
- var cvar)
+ info cvar)
(return
(walk-generic n class params subs
fids gae #t)))
(let ((n2 (inline-lambda-bindings
@@ -406,7 +406,7 @@
(touch)
(debugging
'o "removed unused
parameter to known procedure"
- (car vars) var)
+ (car vars) info)
(if
(expression-has-side-effects? (car args) db)
(make-node
'let
@@ -424,7 +424,7 @@
(if (< (length args) n)
(walk-generic n class params subs
fids gae #t)
(begin
- (debugging 'o "consed rest
parameter at call site" var n)
+ (debugging 'o "consed rest
parameter at call site" info n)
(let-values ([(args rargs)
(split-at args n)])
(let ([n2 (make-node
'##core#call
@@ -449,7 +449,7 @@
(intrinsic? (first (node-parameters lval))))
;; callee is intrinsic
(debugging 'i "inlining call to intrinsic alias"
- var (first (node-parameters lval)))
+ info (first (node-parameters lval)))
(walk
(make-node
'##core#call
diff --git a/scrutinizer.scm b/scrutinizer.scm
index dd2d0a0..332ed2e 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -295,7 +295,7 @@
(pair? (cadr params))) ; sourceinfo has line-number
information?
(let ((n (source-info->line (cadr params))))
(if n
- (sprintf "~a: " n)
+ (sprintf "(~a) " n)
""))
"")
(fragment (first (node-subexpressions node)))))
@@ -781,13 +781,17 @@
(trail0 trail)
(typeenv (type-typeenv (car ts))))
;; first exp is always a variable so ts must be of length 1
- (let loop ((types params) (subs (cdr subs)))
+ (let loop ((types (cdr params)) (subs (cdr subs)))
(cond ((null? types)
- (quit "~ano clause applies in `compiler-typecase'
for expression of type `~s':~a"
- (location-name loc) (car ts)
+ (quit "~a~ano clause applies in
`compiler-typecase' for expression of type `~s':~a"
+ (location-name loc)
+ (if (first params)
+ (sprintf "(~a) " (first params))
+ "")
+ (car ts)
(string-concatenate
(map (lambda (t) (sprintf "\n ~a" t))
- params))))
+ (cdr params)))))
((match-types (car types) (car ts)
(append (type-typeenv (car types))
typeenv)
#t)
diff --git a/support.scm b/support.scm
index 4c0a1e0..c8cda93 100644
--- a/support.scm
+++ b/support.scm
@@ -560,17 +560,17 @@
(list (walk (fourth x)))))
((##core#typecase)
;; clause-head is already stripped
- (let loop ((cls (cddr x)) (types '()) (exps (list (walk (cadr
x)))))
+ (let loop ((cls (cdddr x)) (types '()) (exps (list (walk (caddr
x)))))
(cond ((null? cls) ; no "else" clause given
(make-node
'##core#typecase
- (reverse types)
+ (cons (cadr x) (reverse types))
(reverse
(cons (make-node '##core#undefined '() '()) exps))))
((eq? 'else (caar cls))
(make-node
'##core#typecase
- (reverse (cons '* types))
+ (cons (cadr x) (reverse (cons '* types)))
(reverse (cons (walk (cadar cls)) exps))))
(else (loop (cdr cls)
(cons (caar cls) types)
@@ -649,7 +649,7 @@
((##core#typecase)
`(compiler-typecase
,(walk (first subs))
- ,@(let loop ((types params) (bodies (cdr subs)))
+ ,@(let loop ((types (cdr params)) (bodies (cdr subs)))
(if (null? types)
(if (null? bodies)
'()
@@ -1456,6 +1456,14 @@
(car info)
(and info (->string info))))
+(define (call-info params var)
+ (or (and-let* ((info (and (pair? (cdr params)) (second params))))
+ (and (list? info)
+ (let ((ln (car info))
+ (name (cadr info)))
+ (conc "(" ln ") " var))))
+ var))
+
;;; constant folding support:
diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected
index 0946260..4bea4df 100644
--- a/tests/scrutiny-2.expected
+++ b/tests/scrutiny-2.expected
@@ -1,100 +1,100 @@
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is
called with an argument of type
`(pair fixnum fixnum)' and will always return true
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is
called with an argument of type
`null' and will always return false
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is
called with an argument of type
`null' and will always return false
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is
called with an argument of type
`fixnum' and will always return false
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is
called with an argument of type
`float' and will always return false
Note: at toplevel:
- in procedure call to `list?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is
called with an argument of type
`null' and will always return true
Note: at toplevel:
- in procedure call to `list?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is
called with an argument of type
`null' and will always return true
Note: at toplevel:
- in procedure call to `list?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is
called with an argument of type
`fixnum' and will always return false
Note: at toplevel:
- in procedure call to `list?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is
called with an argument of type
`float' and will always return false
Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is
called with an argument of type
`null' and will always return true
Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is
called with an argument of type
`null' and will always return true
Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is
called with an argument of type
`fixnum' and will always return false
Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is
called with an argument of type
`float' and will always return false
Note: at toplevel:
- in procedure call to `fixnum?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:23) in procedure call to `fixnum?', the predicate is
called with an argument of type
`fixnum' and will always return true
Note: at toplevel:
- in procedure call to `fixnum?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:23) in procedure call to `fixnum?', the predicate is
called with an argument of type
`float' and will always return false
Note: at toplevel:
- in procedure call to `exact?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:24) in procedure call to `exact?', the predicate is
called with an argument of type
`fixnum' and will always return true
Note: at toplevel:
- in procedure call to `exact?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:24) in procedure call to `exact?', the predicate is
called with an argument of type
`float' and will always return false
Note: at toplevel:
- in procedure call to `flonum?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:25) in procedure call to `flonum?', the predicate is
called with an argument of type
`float' and will always return true
Note: at toplevel:
- in procedure call to `flonum?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:25) in procedure call to `flonum?', the predicate is
called with an argument of type
`fixnum' and will always return false
Note: at toplevel:
- in procedure call to `inexact?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:26) in procedure call to `inexact?', the predicate is
called with an argument of type
`float' and will always return true
Note: at toplevel:
- in procedure call to `inexact?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:26) in procedure call to `inexact?', the predicate is
called with an argument of type
`fixnum' and will always return false
Note: at toplevel:
- in procedure call to `number?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is
called with an argument of type
`fixnum' and will always return true
Note: at toplevel:
- in procedure call to `number?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is
called with an argument of type
`float' and will always return true
Note: at toplevel:
- in procedure call to `number?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is
called with an argument of type
`number' and will always return true
Note: at toplevel:
- in procedure call to `number?', the predicate is called with an argument of
type
+ (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is
called with an argument of type
`null' and will always return false
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index bca7f13..31eeb2b 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -16,10 +16,10 @@ Warning: in toplevel procedure `foo':
(if x5 (values 1 2) (values 1 2 (+ (+ ...))))
Warning: at toplevel:
- scrutiny-tests.scm:18: in procedure call to `bar6', expected argument #2 of
type `number', but was given an argument of type `symbol'
+ (scrutiny-tests.scm:18) in procedure call to `bar6', expected argument #2 of
type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- scrutiny-tests.scm:20: in procedure call to `pp', expected 1 argument, but
was given 0 arguments
+ (scrutiny-tests.scm:20) in procedure call to `pp', expected 1 argument, but
was given 0 arguments
Warning: at toplevel:
expected in argument #1 of procedure call `(print (cpu-time))' a single
result, but were given 2 results
@@ -28,13 +28,13 @@ Warning: at toplevel:
expected in argument #1 of procedure call `(print (values))' a single
result, but were given zero results
Warning: at toplevel:
- scrutiny-tests.scm:26: in procedure call to `x7', expected a value of type
`(procedure () *)', but was given a value of type `fixnum'
+ (scrutiny-tests.scm:26) in procedure call to `x7', expected a value of type
`(procedure () *)', but was given a value of type `fixnum'
Warning: at toplevel:
- scrutiny-tests.scm:28: in procedure call to `+', expected argument #1 of
type `number', but was given an argument of type `symbol'
+ (scrutiny-tests.scm:28) in procedure call to `+', expected argument #1 of
type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- scrutiny-tests.scm:28: in procedure call to `+', expected argument #2 of
type `number', but was given an argument of type `symbol'
+ (scrutiny-tests.scm:28) in procedure call to `+', expected argument #2 of
type `number', but was given an argument of type `symbol'
Warning: at toplevel:
assignment of value of type `fixnum' to toplevel variable `car' does not
match declared type `(forall (a123) (procedure car ((pair a123 *)) a123))'
@@ -52,34 +52,34 @@ Note: in toplevel procedure `foo':
(if bar29 3 (##core#undefined))
Warning: in toplevel procedure `foo2':
- scrutiny-tests.scm:57: in procedure call to `string-append', expected
argument #1 of type `string', but was given an argument of type `number'
+ (scrutiny-tests.scm:57) in procedure call to `string-append', expected
argument #1 of type `string', but was given an argument of type `number'
Warning: at toplevel:
- scrutiny-tests.scm:65: in procedure call to `foo3', expected argument #1 of
type `string', but was given an argument of type `fixnum'
+ (scrutiny-tests.scm:65) in procedure call to `foo3', expected argument #1 of
type `string', but was given an argument of type `fixnum'
Warning: in toplevel procedure `foo4':
- scrutiny-tests.scm:70: in procedure call to `+', expected argument #1 of
type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:70) in procedure call to `+', expected argument #1 of
type `number', but was given an argument of type `string'
Warning: in toplevel procedure `foo5':
- scrutiny-tests.scm:76: in procedure call to `+', expected argument #1 of
type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:76) in procedure call to `+', expected argument #1 of
type `number', but was given an argument of type `string'
Warning: in toplevel procedure `foo6':
- scrutiny-tests.scm:82: in procedure call to `+', expected argument #1 of
type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:82) in procedure call to `+', expected argument #1 of
type `number', but was given an argument of type `string'
Warning: at toplevel:
- scrutiny-tests.scm:89: in procedure call to `+', expected argument #1 of
type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:89) in procedure call to `+', expected argument #1 of
type `number', but was given an argument of type `string'
Warning: in toplevel procedure `foo10':
- scrutiny-tests.scm:103: in procedure call to `foo9', expected argument #1 of
type `string', but was given an argument of type `number'
+ (scrutiny-tests.scm:103) in procedure call to `foo9', expected argument #1
of type `string', but was given an argument of type `number'
Warning: in toplevel procedure `foo10':
- scrutiny-tests.scm:104: in procedure call to `+', expected argument #1 of
type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:104) in procedure call to `+', expected argument #1 of
type `number', but was given an argument of type `string'
Note: in toplevel procedure `foo10':
expression returns a result of type `string', but is declared to return
`pair', which is not a subtype
Warning: in toplevel procedure `foo10':
- scrutiny-tests.scm:108: in procedure call to `string-append', expected
argument #1 of type `string', but was given an argument of type `pair'
+ (scrutiny-tests.scm:108) in procedure call to `string-append', expected
argument #1 of type `string', but was given an argument of type `pair'
Warning: in toplevel procedure `foo10':
expression returns 2 values but is declared to have a single result
@@ -91,6 +91,6 @@ Warning: in toplevel procedure `foo10':
expression returns zero values but is declared to have a single result of
type `*'
Warning: in toplevel procedure `foo10':
- scrutiny-tests.scm:111: in procedure call to `*', expected argument #1 of
type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:111) in procedure call to `*', expected argument #1 of
type `number', but was given an argument of type `string'
Warning: redefinition of standard binding: car
--
1.6.0.4
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Chicken-hackers] [PATCH] better line-number tracking,
Felix <=