~ chicken-core (chicken-5) 61f2799f6c42006eeb52d34fe874a370c440a310
commit 61f2799f6c42006eeb52d34fe874a370c440a310
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Mon Feb 13 22:24:19 2012 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Feb 27 10:05:31 2012 +0100
Convert flat lambda literals list into hash table to improve code generation performance
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/batch-driver.scm b/batch-driver.scm
index 65650a7b..e8ad83a3 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -653,13 +653,13 @@
(when a-only (exit 0))
(begin-time)
(receive
- (node literals lliterals lambdas)
+ (node literals lliterals lambda-table)
(prepare-for-code-generation node2 db)
(end-time "preparation")
(begin-time)
(let ((out (if outfile (open-output-file outfile) (current-output-port))) )
(dribble "generating `~A' ..." outfile)
- (generate-code literals lliterals lambdas out filename dynamic db)
+ (generate-code literals lliterals lambda-table out filename dynamic db)
(when outfile
(close-output-port out)))
(end-time "code generation")
diff --git a/c-backend.scm b/c-backend.scm
index f41c59b6..f859cc33 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -59,7 +59,7 @@
;;; Generate target code:
-(define (generate-code literals lliterals lambdas out source-file dynamic db)
+(define (generate-code literals lliterals lambda-table out source-file dynamic db)
;; Don't truncate floating-point precision!
(flonum-print-precision (+ flonum-maximum-decimal-exponent 1))
(let ()
@@ -67,7 +67,7 @@
;; Some helper procedures
(define (find-lambda id)
- (or (find (lambda (ll) (eq? id (lambda-literal-id ll))) lambdas)
+ (or (##sys#hash-table-ref lambda-table id)
(bomb "can't find lambda" id) ) )
;; Compile a single expression
@@ -529,13 +529,12 @@
(define (prototypes)
(let ([large-signatures '()])
(gen #t)
- (for-each
- (lambda (ll)
+ (##sys#hash-table-for-each
+ (lambda (id ll)
(let* ([n (lambda-literal-argument-count ll)]
[customizable (lambda-literal-customizable ll)]
[empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))]
[varlist (intersperse (make-variable-list (if empty-closure (sub1 n) n) "t") #\,)]
- [id (lambda-literal-id ll)]
[rest (lambda-literal-rest-argument ll)]
[rest-mode (lambda-literal-rest-argument-mode ll)]
[direct (lambda-literal-direct ll)]
@@ -580,7 +579,7 @@
;;(when customizable (gen " C_c_regparm"))
(unless direct (gen " C_noret"))
(gen #\;) ] ) ) )
- lambdas)
+ lambda-table)
(for-each
(lambda (s)
(gen #t "typedef void (*C_proc" s ")(C_word")
@@ -622,12 +621,11 @@
(apply gen (intersperse (make-argument-list (+ n 1) "t") #\,))
(gen ");}") ) )
- (for-each
- (lambda (ll)
+ (##sys#hash-table-for-each
+ (lambda (id ll)
(let* ([argc (lambda-literal-argument-count ll)]
[rest (lambda-literal-rest-argument ll)]
[rest-mode (lambda-literal-rest-argument-mode ll)]
- [id (lambda-literal-id ll)]
[customizable (lambda-literal-customizable ll)]
[empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] )
(when empty-closure (set! argc (sub1 argc)))
@@ -645,7 +643,7 @@
(if (and rest (not (eq? rest-mode 'none)))
(set! nsr (lset-adjoin = nsr argc))
(set! ns (lset-adjoin = ns argc)) ) ] ) ) ) )
- lambdas)
+ lambda-table)
(for-each
(lambda (n)
(gen #t #t "C_noret_decl(tr" n ")"
@@ -742,10 +740,9 @@
(else (bomb "invalid unboxed type" t))))
(define (procedures)
- (for-each
- (lambda (ll)
+ (##sys#hash-table-for-each
+ (lambda (id ll)
(let* ((n (lambda-literal-argument-count ll))
- (id (lambda-literal-id ll))
(rname (real-name id db))
(demand (lambda-literal-allocated ll))
(rest (lambda-literal-rest-argument ll))
@@ -909,7 +906,7 @@
n)
ll)
(gen #\}) ) )
- lambdas) )
+ lambda-table) )
(debugging 'p "code generation phase...")
(set! output out)
@@ -921,25 +918,25 @@
(generate-foreign-callback-stubs foreign-callback-stubs db)
(trampolines)
(procedures)
- (emit-procedure-table-info lambdas source-file)
+ (emit-procedure-table-info lambda-table source-file)
(trailer) ) )
;;; Emit procedure table:
-(define (emit-procedure-table-info lambdas sf)
+(define (emit-procedure-table-info lambda-table sf)
(gen #t #t "#ifdef C_ENABLE_PTABLES"
- #t "static C_PTABLE_ENTRY ptable[" (add1 (length lambdas)) "] = {")
- (do ((ll lambdas (cdr ll)))
- ((null? ll)
- (gen #t "{NULL,NULL}};") )
- (let ((id (lambda-literal-id (car ll))))
- (gen #t "{\"" id #\: (string->c-identifier sf) "\",(void*)")
- (if (eq? 'toplevel id)
- (if unit-name
- (gen "C_" unit-name "_toplevel},")
- (gen "C_toplevel},") )
- (gen id "},") ) ) )
+ #t "static C_PTABLE_ENTRY ptable[" (add1 (##sys#hash-table-size lambda-table)) "] = {")
+ (##sys#hash-table-for-each
+ (lambda (id ll)
+ (gen #t "{\"" id #\: (string->c-identifier sf) "\",(void*)")
+ (if (eq? 'toplevel id)
+ (if unit-name
+ (gen "C_" unit-name "_toplevel},")
+ (gen "C_toplevel},") )
+ (gen id "},") ) )
+ lambda-table)
+ (gen #t "{NULL,NULL}};")
(gen #t "#endif")
(gen #t #t "static C_PTABLE_ENTRY *create_ptable(void)")
(gen "{" #t "#ifdef C_ENABLE_PTABLES"
diff --git a/compiler.scm b/compiler.scm
index 84386524..3df1865c 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -2476,7 +2476,8 @@
(literal-count 0)
(lambda-info-literals '())
(lambda-info-literal-count 0)
- (lambdas '())
+ ;; Use analysis db as optimistic heuristic for procedure table size
+ (lambda-table (make-vector (fx* (fxmax current-analysis-database-size 1) 3) '()))
(temporaries 0)
(ubtemporaries '())
(allocated 0)
@@ -2595,29 +2596,30 @@
(debugging 'o "unused rest argument" rest id))
(when (and direct rest)
(bomb "bad direct lambda" id allocated rest) )
- (set! lambdas
- (cons (make-lambda-literal
- id
- (second params)
- vars
- argc
- rest
- (add1 temporaries)
- ubtemporaries
- signatures
- allocated
- (or direct (memq id direct-call-ids))
- (or (get db id 'closure-size) 0)
- (and (not rest)
- (> looping 0)
- (begin
- (debugging 'o "identified direct recursive calls" id looping)
- #t) )
- (or direct (get db id 'customizable))
- rest-mode
- body
- direct)
- lambdas) )
+ (##sys#hash-table-set!
+ lambda-table
+ id
+ (make-lambda-literal
+ id
+ (second params)
+ vars
+ argc
+ rest
+ (add1 temporaries)
+ ubtemporaries
+ signatures
+ allocated
+ (or direct (memq id direct-call-ids))
+ (or (get db id 'closure-size) 0)
+ (and (not rest)
+ (> looping 0)
+ (begin
+ (debugging 'o "identified direct recursive calls" id looping)
+ #t) )
+ (or direct (get db id 'customizable))
+ rest-mode
+ body
+ direct) )
(set! looping lping)
(set! temporaries temps)
(set! ubtemporaries ubtemps)
@@ -2779,4 +2781,4 @@
(when (positive? fastsets)
(debugging 'o "fast global assignments" fastsets))
(values node2 (##sys#fast-reverse literals)
- (##sys#fast-reverse lambda-info-literals) lambdas) ) ) )
+ (##sys#fast-reverse lambda-info-literals) lambda-table) ) ) )
diff --git a/eval.scm b/eval.scm
index 5f4bfc29..a2fdb5cb 100644
--- a/eval.scm
+++ b/eval.scm
@@ -163,6 +163,11 @@
b
(loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) )
+(define (##sys#hash-table-size ht)
+ (let loop ((len (##sys#size ht)) (bkt 0) (size 0))
+ (if (fx= bkt len)
+ size
+ (loop len (fx+ bkt 1) (fx+ size (##sys#length (##sys#slot ht bkt)))))))
;;; Compile lambda to closure:
Trap