>From b9fa9e93720c61b0e0efdabfa12c0477fee71636 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Mon, 13 Feb 2012 22:24:19 +0100 Subject: [PATCH] Convert flat lambda literals list into hash table to improve code generation performance --- batch-driver.scm | 4 ++-- c-backend.scm | 51 ++++++++++++++++++++++++--------------------------- compiler.scm | 52 +++++++++++++++++++++++++++------------------------- eval.scm | 5 +++++ 4 files changed, 58 insertions(+), 54 deletions(-) diff --git a/batch-driver.scm b/batch-driver.scm index 65650a7..e8ad83a 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 c5c81e0..744717f 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 8438652..3df1865 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 5f4bfc2..a2fdb5c 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: -- 1.7.3.4