~ chicken-core (chicken-5) ab53ba3f0f4e133ab6b71d90845f1f570bc5d0e3
commit ab53ba3f0f4e133ab6b71d90845f1f570bc5d0e3
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Apr 11 11:58:28 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Apr 11 11:58:28 2011 +0200
CPS does not treat ##core#inline[_allocate] as atomic to avoid unboxing problem with nested unboxing; -debug h instead of question-mark; -debug i; updated scrutiny.expected; modules used non-existant map-se in debugging build
diff --git a/batch-driver.scm b/batch-driver.scm
index 639ff2eb..dfb115cf 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -178,7 +178,7 @@
(map (lambda (c) (string->symbol (string c)))
(string->list do) ) )
(collect-options 'debug) ) )
- (when (memq '? debugging-chicken)
+ (when (memq 'h debugging-chicken)
(print-debug-options)
(exit))
(set! dumpnodes (memq '|D| debugging-chicken))
diff --git a/compiler.scm b/compiler.scm
index 5d8be8c3..065b58ba 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1497,8 +1497,8 @@
(eq? 'procedure (car type))
(symbol? (cadr type)))
(set-car! (cdr type) name))
- (mark-variable name '##core#type type)
- (mark-variable name '##core#declared-type)
+ (mark-variable name '##compiler#type type)
+ (mark-variable name '##compiler#declared-type)
(when (pair? (cddr spec))
(mark-variable
name '##compiler#specializations
@@ -1731,8 +1731,8 @@
(define (atomic? n)
(let ((class (node-class n)))
(or (memq class '(quote ##core#variable ##core#undefined ##core#global-ref))
- (and (memq class '(##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update
- ##core#inline_loc_ref ##core#inline_loc_update))
+ (and (memq class '(##core#inline_ref ##core#inline_update ##core#inline_loc_ref
+ ##core#inline_loc_update))
(every atomic? (node-subexpressions n)) ) ) ) )
(walk node values) )
diff --git a/expand.scm b/expand.scm
index 0f305baa..27fc8787 100644
--- a/expand.scm
+++ b/expand.scm
@@ -50,8 +50,6 @@
(define-alias dm d)
(define-alias dx d)
-(define-syntax d (syntax-rules () ((_ . _) (void))))
-
(define-inline (getp sym prop)
(##core#inline "C_i_getprop" sym prop #f))
diff --git a/modules.scm b/modules.scm
index d60560e2..f67c5a63 100644
--- a/modules.scm
+++ b/modules.scm
@@ -52,6 +52,12 @@
((getp id '##core#macro-alias))
(else #f)))
+#+debugbuild
+(define (map-se se)
+ (map (lambda (a)
+ (cons (car a) (if (symbol? (cdr a)) (cdr a) '<macro>)))
+ se))
+
;;; low-level module support
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 4c6a8e35..bbd71d42 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -28,7 +28,8 @@
(unit scrutinizer)
(hide match-specialization specialize-node! specialization-statistics
procedure-type? named? procedure-result-types procedure-argument-types
- noreturn-type? rest-type procedure-name d-depth))
+ noreturn-type? rest-type procedure-name d-depth
+ compatible-types? type<=?))
(include "compiler-namespace")
@@ -374,50 +375,6 @@
((match (car results1) (car results2))
(match-results (cdr results1) (cdr results2)))
(else #f)))
- (define (compatible-types? t1 t2)
- (or (type<=? t1 t2)
- (type<=? t2 t1)))
- (define (type<=? t1 t2)
- (or (eq? t1 t2)
- (memq t2 '(* undefined))
- (case t2
- ((list) (memq t1 '(null pair)))
- ((procedure) (and (pair? t1) (eq? 'procedure (car t1))))
- ((number) (memq t1 '(fixnum float)))
- (else
- (and (pair? t1) (pair? t2)
- (case (car t1)
- ((or) (every (cut type<=? <> t2) (cdr t1)))
- ((procedure)
- (let ((args1 (if (named? t1) (caddr t1) (cadr t1)))
- (args2 (if (named? t2) (caddr t2) (cadr t2)))
- (res1 (if (named? t1) (cdddr t1) (cddr t1)))
- (res2 (if (named? t2) (cdddr t2) (cddr t2))) )
- (let loop1 ((args1 args1)
- (args2 args2)
- (m1 0)
- (m2 0))
- (cond ((null? args1)
- (and (or (null? args2) (> m2 0))
- (let loop2 ((res1 res1) (res2 res2))
- (cond ((eq? '* res2) #t)
- ((null? res2) (null? res1))
- ((eq? '* res1) #f)
- ((type<=? (car res1) (car res2))
- (loop2 (cdr res1) (cdr res2)))
- (else #f)))))
- ((null? args2) #f)
- ((eq? (car args1) '#!optional)
- (loop1 (cdr args1) args2 1 m2))
- ((eq? (car args2) '#!optional)
- (loop1 args1 (cdr args2) m1 1))
- ((eq? (car args1) '#!rest)
- (loop1 (cdr args1) args2 2 m2))
- ((eq? (car args2) '#!rest)
- (loop1 args1 (cdr args2) m1 2))
- ((type<=? (car args1) (car args2))
- (loop1 (cdr args1) (cdr args2) m1 m2))
- (else #f)))))))))))
(define (multiples n)
(if (= n 1) "" "s"))
(define (single what tv loc)
@@ -697,7 +654,7 @@
(and-let* ((val (or (get db var 'value)
(get db var 'local-value))))
(when (eq? val (first subs))
- (debugging 'x (sprintf "(: ~s ~s)" var rt))
+ (debugging 'i (sprintf "(: ~s ~s)" var rt))
(mark-variable var '##compiler#declared-type)
(mark-variable var '##compiler#type rt))))
(when b
@@ -797,6 +754,52 @@
(debugging 'x "safe calls" safe-calls))
rn)))
+(define (compatible-types? t1 t2)
+ (or (type<=? t1 t2)
+ (type<=? t2 t1)))
+
+(define (type<=? t1 t2)
+ (or (eq? t1 t2)
+ (memq t2 '(* undefined))
+ (case t2
+ ((list) (memq t1 '(null pair)))
+ ((procedure) (and (pair? t1) (eq? 'procedure (car t1))))
+ ((number) (memq t1 '(fixnum float)))
+ (else
+ (and (pair? t1) (pair? t2)
+ (case (car t1)
+ ((or) (every (cut type<=? <> t2) (cdr t1)))
+ ((procedure)
+ (let ((args1 (if (named? t1) (caddr t1) (cadr t1)))
+ (args2 (if (named? t2) (caddr t2) (cadr t2)))
+ (res1 (if (named? t1) (cdddr t1) (cddr t1)))
+ (res2 (if (named? t2) (cdddr t2) (cddr t2))) )
+ (let loop1 ((args1 args1)
+ (args2 args2)
+ (m1 0)
+ (m2 0))
+ (cond ((null? args1)
+ (and (or (null? args2) (> m2 0))
+ (let loop2 ((res1 res1) (res2 res2))
+ (cond ((eq? '* res2) #t)
+ ((null? res2) (null? res1))
+ ((eq? '* res1) #f)
+ ((type<=? (car res1) (car res2))
+ (loop2 (cdr res1) (cdr res2)))
+ (else #f)))))
+ ((null? args2) #f)
+ ((eq? (car args1) '#!optional)
+ (loop1 (cdr args1) args2 1 m2))
+ ((eq? (car args2) '#!optional)
+ (loop1 args1 (cdr args2) m1 1))
+ ((eq? (car args1) '#!rest)
+ (loop1 (cdr args1) args2 2 m2))
+ ((eq? (car args2) '#!rest)
+ (loop1 args1 (cdr args2) m1 2))
+ ((type<=? (car args1) (car args2))
+ (loop1 (cdr args1) (cdr args2) m1 m2))
+ (else #f)))))))))))
+
(define (procedure-type? t)
(or (eq? 'procedure t)
(and (pair? t)
diff --git a/support.scm b/support.scm
index d2c11dd5..de5895d2 100644
--- a/support.scm
+++ b/support.scm
@@ -749,10 +749,10 @@
(##sys#hash-table-for-each
(lambda (sym plist)
(when (variable-visible? sym)
- (when (variable-mark sym '##core#declared-type)
+ (when (variable-mark sym '##compiler#declared-type)
(let ((specs
(or (variable-mark sym '##compiler#specializations) '())))
- (pp (cons* sym (variable-mark sym '##core#type) specs))))))
+ (pp (cons* sym (variable-mark sym '##compiler#type) specs))))))
db)
(print "; END OF FILE"))))
@@ -1616,6 +1616,7 @@ Available debugging options:
c print every expression before macro-expansion
u lists all unassigned global variable references
d lists all assigned global variables
+ i show inferred type information for unexported globals
x display information about experimental features
D when printing nodes, use node-tree output
N show the real-name mapping table
@@ -1633,7 +1634,7 @@ Available debugging options:
7 show expressions after complete optimization
8 show database after final analysis
9 show expressions after closure conversion
- ? you already figured that out
+ h you already figured that out
EOF
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index d919b18b..c33165bd 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -45,4 +45,10 @@ Warning: at toplevel:
Warning: at toplevel:
g89: in procedure call to `g89', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
+Warning: in toplevel procedure `foo':
+ expected value of type boolean in conditional but were given a value of
+type `(procedure bar24 () *)' which is always true:
+
+(if bar24 '3 (##core#undefined))
+
Warning: redefinition of standard binding: car
diff --git a/unboxing.scm b/unboxing.scm
index 3059bb72..961dc9cc 100644
--- a/unboxing.scm
+++ b/unboxing.scm
@@ -105,7 +105,7 @@
(let ((n2 (make-node
'##core#inline_unboxed (list alt)
(reverse iargs))))
- (pp (build-expression-tree n2))
+ ;(pp (build-expression-tree n2))
(if (and dest (cdr dest))
n2
(let ((tmp (gensym "tu")))
@@ -179,6 +179,7 @@
(define (straighten-binding! n)
;; change `(let ((<v> (let (...) <x2>))) <x>)' into
;; `(let (...) (let ((<v> <x2>)) <x>))'
+ ;; (also for "##core#let_unboxed")
(let* ((subs (node-subexpressions n))
(bnode (first subs))
(bcl (node-class bnode)))
@@ -203,6 +204,7 @@
(define (straighten-conditional! n)
;; change `(if (let (...) <x1>) <x2> <x3>)' into
;; `(let (...) (if <x1> <x2> <x3>))'
+ ;; (also for "##core#let_unboxed")
(let* ((subs (node-subexpressions n))
(bnode (first subs))
(bcl (node-class bnode)))
@@ -226,6 +228,7 @@
(define (straighten-call! n)
;; change `(<proc> ... (let (...) <x>) ...)' into
;; `(let (...) (<proc> ... <x> ...))'
+ ;; (also for "##core#let_unboxed")
(let* ((class (node-class n))
(subs (node-subexpressions n))
(params (node-parameters n))
@@ -381,8 +384,11 @@
(for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
#f))))
- (d "walk lambda: ~a" id)
+ (d "walk lambda: ~a (pass 1)" id)
+ ;; walk once and mark boxed/unboxed variables in environment
(walk body #f #f #f)
+ ;; walk a second time and rewrite
+ (d "walk lambda: ~a (pass 2)" id)
(walk body #f #f #t)))
(walk-lambda #f '() node)
@@ -463,25 +469,3 @@
(C_u_i_pointer_f32_set (pointer flonum) flonum "C_ub_i_pointer_f32_set")
(C_u_i_pointer_f64_set (pointer flonum) flonum "C_ub_i_pointer_f64_set")
(C_null_pointerp (pointer) bool "C_ub_i_null_pointerp"))
-
-
-;;;
-
-#|XXX
-
-This breaks:
-
-(use srfi-4)
-
-(define (foo)
- (let ((v (f64vector 1.0 2.0))
- (n (f64vector-ref v 0))
- (m (f64vector-ref v 1)))
- (print (fp+ (fp* n m) (fp* n m)))))
-
-(foo)
-
-- fp* gets unboxed before fp+ and will result incorrectly nested ##core#let_unboxed
- forms in argument position of the final ##core#inline_unboxed form.
-
-|#
Trap