[Chicken-users] A proposed patch to crunch

[Ivan Raikov]

Hi all,

   Attached is a small patch that allows programs generated by
chicken-crunch to use the libarena memory allocator interface. I am
curious to hear what users of the crunch package think about this
extension. 

   -Ivan

diff -u crunch/chicken-crunch.scm crunch.new/chicken-crunch.scm
--- crunch/chicken-crunch.scm   2007-04-30 12:25:44.000000000 +0900
+++ crunch.new/chicken-crunch.scm       2007-04-30 12:25:14.000000000 +0900
@@ -57,6 +57,13 @@
   -expand       only show code after expansion
   -entry NAME   set entry-point procedure
   -translate    only generate C++, don't compile
+  -use-arena    use the Arena memory allocator
+
+  Arena-specific options:
+
+  -arena-pool SIZE:N,...   define Arena pool buckets
+  -arena-include DIR       Arena include directory (default: /usr/include)
+  -arena-lib DIR           Arena library directory (default: /usr/lib)
 
   All other options (arguments beginning with "-") are passed to
   the C++ compiler. FILENAME may be "-", which reads source code
@@ -75,6 +82,10 @@
        (tonly #f)
        (debug #f)
        (entry #f)
+       (use-arena #f)
+       (arena-pool '((1 64)))
+       (arena-include  "/usr/include")
+       (arena-lib      "/usr/lib")
        (copts '()))
     (let loop ((args args))
       (match args
@@ -99,21 +110,48 @@
                                      (crunch-compile 
                                       code
                                       outfile 
+                                      use-arena
                                       entry-point: entry
                                       debug: debug)))
                          (unless entry
-                           (format
-                            outfile
-                            "\nint main(int argc, char *argv[]) { C_main_argc 
= argc; C_main_argv = argv; ~a(); return ~:[0~;~:*~a()~]; }\n"
-                            f
-                            (and-let* ((a (assq 'main exports))) (cadr a)) ) ) 
) ) ) ) ) )
+                           (begin
+                             (format outfile "\n")
+                             (if use-arena
+                                 (begin
+                                   (format outfile "const struct 
pool_bucket_options crunch_bkts[] = {\n")
+                                   (format outfile "~{   { ~{~a, ~a~} 
}~^,\n~}\n" arena-pool)
+                                   (format outfile "};\n")
+                                   (format outfile "\n")
+                                   (format outfile "struct pool_options 
crunch_pool_defaults = {\n")
+                                   (format outfile "   
ARENA_SYSTEM_ALIGNMENT,\n")
+                                   (format outfile "   crunch_bkts\n")
+                                   (format outfile "};\n")
+                                   (format outfile "\n")))
+                             (format outfile "int main(int argc, char 
*argv[])\n")
+                             (format outfile "{\n")
+                             (if use-arena 
+                                 (begin
+                                   (format outfile "  POOL *p0;\n")
+                                   (format outfile "  if (!(p0 = 
pool_open(&crunch_pool_defaults,ARENA_STDLIB)))\n")
+                                   (format outfile "     
err(EXIT_FAILURE,\"pool_open(&crunch_pool_defaults,0)\");\n")
+                                   (format outfile "  crunch_pool = 
pool_export(p0);\n")
+                                   (format outfile "\n")))
+                             (format outfile "  C_main_argc = argc;\n")
+                             (format outfile "  C_main_argv = argv;\n")
+                             (format outfile "  ~a(); return 
~:[0~;~:*~a()~];\n"
+                                     f (and-let* ((a (assq 'main exports))) 
(cadr a)) )
+                             (format outfile "}\n") ) ) ) ) ) ) ))
           (if tonly
               0
-              (let ((ccmd (string-intersperse (cons* *c++* cfile (reverse 
copts)))))
-                (when debug (print "  " ccmd))
-                (if (zero? (system ccmd))
-                    0
-                    1)))) )
+              (let ((arena-cc-opts (if use-arena (list (conc "-I" 
arena-include) 
+                                                       (conc "-L" arena-lib)
+                                                       "-larena")
+                                       (list))))
+                (let ((ccmd (string-intersperse (cons* *c++* cfile (append 
arena-cc-opts (reverse copts))))))
+                  (when debug (print "  " ccmd))
+                  (if (zero? (system ccmd))
+                      0
+                      1))))) )
         (((or "-h" "-help" "--help") . _) (usage))
        (("-o" fname . more)
         (set! out fname)
@@ -140,6 +178,18 @@
        (("-entry" name . more)
         (set! entry (string->symbol name))
         (loop more) )
+       (("-use-arena" . more)
+        (set! use-arena #t)
+        (loop more))
+       (("-arena-pool" bkts . more)
+        (set! arena-pool (map (lambda (b) (string-split b ":")) (string-split 
bkts ",")))
+        (loop more))
+       (("-arena-include" dir . more)
+        (set! arena-include dir)
+        (loop more))
+       (("-arena-lib" dir . more)
+        (set! arena-lib dir)
+        (loop more))
        (((? option? o) . more)
         (set! copts (cons o copts)) 
         (loop more))
diff -u crunch/crunch-compiler.scm crunch.new/crunch-compiler.scm
--- crunch/crunch-compiler.scm  2007-04-30 12:26:09.000000000 +0900
+++ crunch.new/crunch-compiler.scm      2007-04-30 12:25:14.000000000 +0900
@@ -699,7 +699,7 @@
           (else (bomb #f "invalid literal: ~s" x)))
      (format port ";~%static ~a(l~a);~%" (c-type type id) id))))
 
-(define (crunch-compile expr #!optional (port (current-output-port)) 
+(define (crunch-compile expr #!optional (port (current-output-port)) (arena #f)
                        #!key (debug *crunch-debug*) entry-point)
   (fluid-let ((*crunch-debug* debug)
              (*types* '())) ; bind first because of call to `make-typevar' 
below
@@ -755,6 +755,7 @@
                     (emit "return ~a; }\n" (car v)) ) ) ) ) ) )
        (display "// ---------- CRUNCH ----------\n\n" port)
        (format port "~{~a~2%~}" (reverse *verbatim*))
+       (if arena (format port "#define CRUNCH_USE_ARENA 1\n"))
        (format port "#include \"~acrunch.h\"~2%" *header-path*)
        (hash-table-walk
         *globals*
@@ -872,18 +873,18 @@
     ((double) "double")
     ((bool) "crunch_bool")
     ((number) "int")
-    ((c-string string) "crunch_string")
     ((blob) "crunch_blob")
+    ((c-string string) "crunch_string")
     ((pointer c-pointer) "void *")
-    ((u8vector) "crunch_u8vector")
-    ((s8vector) "crunch_s8vector")
-    ((u16vector) "crunch_u16vector")
-    ((s16vector) "crunch_s16vector")
-    ((u32vector) "crunch_u32vector")
-    ((s32vector) "crunch_s32vector")
-    ((f32vector) "crunch_f32vector")
-    ((f64vector) "crunch_f64vector")
-    ((void) "crunch_unspecified")
+    ((u8vector)   "crunch_u8vector")
+    ((s8vector)   "crunch_s8vector")
+    ((u16vector)  "crunch_u16vector")
+    ((s16vector)  "crunch_s16vector")
+    ((u32vector)  "crunch_u32vector")
+    ((s32vector)  "crunch_s32vector")
+    ((f32vector)  "crunch_f32vector")
+    ((f64vector)  "crunch_f64vector")
+    ((void)       "crunch_unspecified")
     (else (bomb #f "invalid native type: ~a" t))))
 
 (define (crunch-register-primitive name args result realname #!optional 
callback refreturn)
diff -u crunch/crunch.h crunch.new/crunch.h
--- crunch/crunch.h     2007-04-30 12:25:44.000000000 +0900
+++ crunch.new/crunch.h 2007-04-30 12:25:14.000000000 +0900
@@ -66,6 +66,21 @@
 #define crunch_primitive    static inline
 #define crunch_local        static
 
+#ifdef CRUNCH_USE_ARENA
+
+#include <err.h>
+#include <arena/pool.h>
+#include <arena/proto.h>
+
+// libarena pool allocator; must be initialized in main()
+const struct arena_prototype *crunch_pool;
+
+#define crunch_malloc(sz)      crunch_pool->malloc(crunch_pool,sz,0)
+#define crunch_malloc_ref(n)   (int 
*)(crunch_pool->malloc(crunch_pool,sizeof(n),0))
+#define crunch_free
+
+#endif // CRUNCH_USE_ARENA
+
 #ifndef crunch_malloc
 crunch_local void *crunch_malloc(size_t sz) {
   void *p = malloc(sz);
@@ -150,7 +165,7 @@
       ptr = sp.ptr;
     }
 
-    return this;
+    return *this;
   }
     
   int length() const {