Re: [Chicken-hackers] [PATH] Use hash table instead of flat list for lambda literals

[Alan Post]

If you were going to change the initial hash table size, you could
pick a fraction of the size of the analysis database.  The numbers
test suggests 1/10th, for instance.

-Alan

On Mon, Feb 13, 2012 at 10:36:33PM +0100, Peter Bex wrote:
> Hi!
> 
> Here's another pretty straightforward patch. This one cuts the code
> generation time in half for the numbers test (I'm lazy today, I didn't
> bother to figure out a synthetic program that gets the same behavior, but
> theoretically this should be exponential in the worst case, too)
> 
> The change is pretty simple; prepare-for-code-generation walks the node
> tree, assembles a list of all lambda literals and returns it, which
> generate-code then consumes to generate a list of all lambdas.
> In two places it uses an internal FIND-LAMBDA helper procedure, which
> loops through the list and tries to find a lambda literal that has
> the same ID as a reference to it in a call site.
> 
> Instead of looping through the entire list, it could just use a hash
> table, which requires us to modify prepare-for-code-generation to
> create one.  The hash table size is initialized to the analysis database
> size, perhaps this could be tweaked further to save on memory usage
> as this is most likely way too much since there are usually more
> "normal" variables than lambdas.  For example, the numbers test has
> 14051 lambdas, and the program size is about 10 times as big.
> 
> OTOH, theoretically a program could be "lambdas all the way down",
> in which case the guess is right on the mark.  That's why I kept it
> the way it is for now (and it's a convenient number to use since
> it's already being calculated and it's never going to be too small).
> 
> Cheers,
> Peter
> -- 
> http://sjamaan.ath.cx
> --
> "The process of preparing programs for a digital computer
>  is especially attractive, not only because it can be economically
>  and scientifically rewarding, but also because it can be an aesthetic
>  experience much like composing poetry or music."
>                                                       -- Donald Knuth

> From b9fa9e93720c61b0e0efdabfa12c0477fee71636 Mon Sep 17 00:00:00 2001
> From: Peter Bex <address@hidden>
> 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
> 

> _______________________________________________
> Chicken-hackers mailing list
> address@hidden
> https://lists.nongnu.org/mailman/listinfo/chicken-hackers


-- 
.i ma'a lo bradi cu penmi gi'e du