~ chicken-core (chicken-5) e26866e51f129296f77cb924fe67ed9270a96b32
commit e26866e51f129296f77cb924fe67ed9270a96b32
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Sep 18 12:48:16 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Sep 18 12:48:16 2010 +0200
fiddling
diff --git a/compiler.scm b/compiler.scm
index 07a2617e..5ae4664f 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1912,16 +1912,16 @@
(set! value (and (not unknown) value))
(set! local-value (and (not unknown) local-value))
- ;; If this is the first analysis, register known local or potentially known global lambda-value id's
- ;; along with their names:
+ ;; If this is the first analysis, register known local or potentially known global
+ ;; lambda-value id's along with their names:
(when (and first-analysis
(eq? '##core#lambda
(and-let* ([val (or value (and global pvalue))])
(node-class val) ) ) )
(set-real-name! (first (node-parameters (or value pvalue))) sym) )
- ;; If this is the first analysis and the variable is global and has no references and we are
- ;; in block mode, then issue warning:
+ ;; If this is the first analysis and the variable is global and has no references
+ ;; and we are in block mode, then issue warning:
(when (and first-analysis
global
(null? references)
@@ -1932,14 +1932,16 @@
(when (and (not (variable-visible? sym))
(not (variable-mark sym '##compiler#constant)) )
(##sys#notice
- (sprintf "global variable `~S' is only locally visible and never used" sym) ) ) )
+ (sprintf "global variable `~S' is only locally visible and never used"
+ sym) ) ) )
;; Make 'boxed, if 'assigned & 'captured:
(when (and assigned captured)
(quick-put! plist 'boxed #t) )
- ;; Make 'contractable, if it has a procedure as known value, has only one use and one call-site and
- ;; if the lambda has no free non-global variables or is an internal lambda. Make 'inlinable if
+ ;; Make 'contractable, if it has a procedure as known value, has only one use
+ ;; and one call-site and if the lambda has no free non-global variables
+ ;; or is an internal lambda. Make 'inlinable if
;; use/call count is not 1:
(cond (value
(let ((valparams (node-parameters value)))
@@ -1969,7 +1971,8 @@
(when (node? n)
(cond (assigned
(debugging
- 'i "global inlining candidate was assigned and will not be inlined"
+ 'i
+ "global inlining candidate was assigned and will not be inlined"
sym)
(mark-variable sym '##compiler#inline-global 'no))
(else
diff --git a/expand.scm b/expand.scm
index 6a16a9cd..52de4cff 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1807,7 +1807,9 @@
(map (lambda (se)
(if (symbol? se)
(or (assq se me)
- (##sys#error "unknown macro referenced while registering module" se name))
+ (##sys#error
+ "unknown syntax referenced while registering module"
+ se name))
se))
sexports))))
(set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
diff --git a/optimizer.scm b/optimizer.scm
index 65d87343..91ed92e1 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -287,7 +287,8 @@
(touch)
(for-each (cut put! db <> 'inline-target #t) fids)
(walk
- (inline-lambda-bindings llist args (first (node-subexpressions lval)) #f db)
+ (inline-lambda-bindings
+ llist args (first (node-subexpressions lval)) #f db)
fids) ) )
((variable-mark var '##compiler#pure) =>
(lambda (pb)
@@ -341,7 +342,8 @@
(debugging 'o "inlining procedure" var)
(touch)
(walk
- (inline-lambda-bindings llist args (first (node-subexpressions lval)) #t db)
+ (inline-lambda-bindings
+ llist args (first (node-subexpressions lval)) #t db)
fids) )
((test ifid 'has-unused-parameters)
(if (< (length args) argc) ; Expression was already optimized (should this happen?)
diff --git a/runtime.c b/runtime.c
index 6113b573..5a65af89 100644
--- a/runtime.c
+++ b/runtime.c
@@ -2023,9 +2023,10 @@ C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE
{
C_word bucket, sym, s;
- for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket)) {
+ for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;
+ bucket = C_u_i_cdr(bucket)) {
sym = C_u_i_car(bucket);
- s = C_u_i_cdr(sym);
+ s = C_block_item(sym, 1);
if(C_header_size(s) == (C_word)len
&& !C_memcmp(str, (C_char *)((C_SCHEME_BLOCK *)s)->data, len))
diff --git a/srfi-69.scm b/srfi-69.scm
index 6958e3d8..16115eaf 100644
--- a/srfi-69.scm
+++ b/srfi-69.scm
@@ -654,8 +654,7 @@
(define hash-table-update!
(let ([core-eq? eq?] )
- (lambda (ht key
- (func (lambda (x) x))
+ (lambda (ht key func
#!optional
(thunk
(let ([thunk (##sys#slot ht 9)])
diff --git a/support.scm b/support.scm
index 143ef741..fa263dfc 100644
--- a/support.scm
+++ b/support.scm
@@ -381,11 +381,14 @@
;;; Display analysis database:
(define display-analysis-database
- (let ((names '((captured . cpt) (assigned . set) (boxed . box) (global . glo) (assigned-locally . stl)
- (contractable . con) (standard-binding . stb) (simple . sim) (inlinable . inl)
+ (let ((names '((captured . cpt) (assigned . set) (boxed . box) (global . glo)
+ (assigned-locally . stl)
+ (contractable . con) (standard-binding . stb) (simple . sim)
+ (inlinable . inl)
(collapsable . col) (removable . rem) (constant . con)
(inline-target . ilt) (inline-transient . itr)
- (undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb) (inline-export . ilx)
+ (undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb)
+ (inline-export . ilx) (hidden-refs . hrf)
(customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) )
(omit #f))
(lambda (db)
@@ -592,7 +595,10 @@
'let (list (last rlist))
(list (if (null? rargs)
(qnode '())
- (make-node '##core#inline_allocate (list "C_a_i_list" (* 3 (length rargs))) rargs) )
+ (make-node
+ '##core#inline_allocate
+ (list "C_a_i_list" (* 3 (length rargs)))
+ rargs) )
body) )
body)
(take rlist argc)
@@ -611,6 +617,7 @@
[(##core#variable)
(let ((var (first params)))
(when (get db var 'contractable)
+ (debugging 'i "unmarking copied reference to contractable procedure" var)
(put! db var 'contractable #f) )
(varnode (rename var rl))) ]
[(set!)
@@ -1161,7 +1168,7 @@
(for-each (lambda (n) (walk n e)) ns) )
(walk node '())
- (values vars hvars) ) )
+ (values vars hvars) ) ) ; => freevars hiddenvars
;;; Some pathname operations:
diff --git a/types.db b/types.db
index 1200d696..1bc874ee 100644
--- a/types.db
+++ b/types.db
@@ -1355,7 +1355,7 @@
(hash-table-remove! (procedure hash-table-remove! ((struct hash-table) (procedure (* *) *)) undefined))
(hash-table-set! (procedure hash-table-set! ((struct hash-table) * *) undefined))
(hash-table-size (procedure hash-table-size ((struct hash-table)) fixnum))
-(hash-table-update! (procedure hash-table-update! ((struct hash-table) * #!optional (procedure (*) *) (procedure () *)) *))
+(hash-table-update! (procedure hash-table-update! ((struct hash-table) * (procedure (*) *) #!optional (procedure () *)) *))
(hash-table-update!/default (procedure hash-table-update!/default ((struct hash-table) * (procedure (*) *) *) *))
(hash-table-values (procedure hash-table-values ((struct hash-table)) list))
(hash-table-walk (procedure hash-table-walk ((struct hash-table) (procedure (* *) . *)) undefined))
Trap