* eval.c (plus_s, prof_s): New symbol global variables.

(op_prof, me_pprof): New static functions.
(eval_init): Intern prof symbol, store in prof_s.
Captured interned + symbol in plus_s. Register prof operator and pprof
macro.

* gc.c (gc_bytes): New global variable.
(more): Use nse function chk_malloc_gc_more instead of chk_malloc.
(make_obj): Increment gc_bytes.

* lib.c (malloc_bytes): New global variable.
(chk_malloc, chk_realloc): Increment malloc_bytes.
(chk_calloc): Bugfix: incorrect size in recursion into oom_realloc.
Incorrect calculation of malloc_high_bound.  Increment malloc_bytes.
(chk_malloc_gc_more): New function.

* lib.h (alloc_bytes_t): New typedef.
(malloc_bytes, gc_bytes): Declared.
(chk_malloc_gc_more): Declared.

* stream.c (format_s): New symbol global.
(stream_init): format_s inited.
format_s used to register formatv function.

* stream.h (format_s): Declared.

* txr.1: Documented prof and pprof.

* genvim.txr: Recognize reg_fun calls with intern
followed by a preceding assignment or other syntax.

* txr.vim: Updated.

10 files changed, 223 insertions, 60 deletions

diff --git a/ChangeLog b/ChangeLog
index 20b772da..dac12d72 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,38 @@
+2014-03-12  Kaz Kylheku  <kaz@kylheku.com>
+
+	* eval.c (plus_s, prof_s): New symbol global variables.
+	(op_prof, me_pprof): New static functions.
+	(eval_init): Intern prof symbol, store in prof_s.
+	Captured interned + symbol in plus_s. Register prof operator and pprof
+	macro.
+
+	* gc.c (gc_bytes): New global variable.
+	(more): Use nse function chk_malloc_gc_more instead of chk_malloc.
+	(make_obj): Increment gc_bytes.
+
+	* lib.c (malloc_bytes): New global variable.
+	(chk_malloc, chk_realloc): Increment malloc_bytes.
+	(chk_calloc): Bugfix: incorrect size in recursion into oom_realloc.
+	Incorrect calculation of malloc_high_bound.  Increment malloc_bytes.
+	(chk_malloc_gc_more): New function.
+
+	* lib.h (alloc_bytes_t): New typedef.
+	(malloc_bytes, gc_bytes): Declared.
+	(chk_malloc_gc_more): Declared.
+
+	* stream.c (format_s): New symbol global.
+	(stream_init): format_s inited.
+	format_s used to register formatv function.
+
+	* stream.h (format_s): Declared.
+
+	* txr.1: Documented prof and pprof.
+
+	* genvim.txr: Recognize reg_fun calls with intern
+	followed by a preceding assignment or other syntax.
+
+	* txr.vim: Updated.
+
 2014-03-11  Kaz Kylheku  <kaz@kylheku.com>
 
 	* configure: new test for fcntl.
diff --git a/eval.c b/eval.c
index 6abbf616..8cf1f75c 100644
--- a/eval.c
+++ b/eval.c
@@ -79,12 +79,12 @@ val for_s, for_star_s, each_s, each_star_s, collect_each_s, collect_each_star_s;
 val append_each_s, append_each_star_s;
 val dohash_s;
 val uw_protect_s, return_s, return_from_s;
-val list_s, append_s, apply_s, gen_s, gun_s, generate_s, rest_s;
+val list_s, append_s, apply_s, gen_s, gun_s, generate_s, rest_s, plus_s;
 val promise_s, op_s;
 val hash_lit_s, hash_construct_s;
 val vector_lit_s, vector_list_s;
 val macro_time_s, with_saved_vars_s, macrolet_s;
-val defsymacro_s, symacrolet_s;
+val defsymacro_s, symacrolet_s, prof_s;
 
 val special_s, whole_k;
 
@@ -1961,6 +1961,19 @@ static val op_with_saved_vars(val form, val env)
   return result;
 }
 
+static val op_prof(val form, val env)
+{
+  clock_t start_time = clock();
+  alloc_bytes_t start_mlbytes = malloc_bytes;
+  alloc_bytes_t start_gcbytes = gc_bytes;
+  val result = eval_progn(rest(form), env, form);
+  return list(result,
+              num(malloc_bytes - start_mlbytes),
+              num(gc_bytes - start_gcbytes),
+              trunc(mul(num(clock() - start_time), num_fast(1000)), num_fast(CLOCKS_PER_SEC)),
+              nao);
+}
+
 static val me_gen(val form, val menv)
 {
   (void) menv;
@@ -1986,6 +1999,27 @@ static val me_delay(val form, val menv)
               cons(lambda_s, cons(nil, rest(form))), nao);
 }
 
+static val me_pprof(val form, val menv)
+{
+  val retval = gensym(lit("retval-"));
+  val mbytes = gensym(lit("mal-bytes-"));
+  val gcbytes = gensym(lit("gc-bytes-"));
+  val msecs = gensym(lit("usecs-"));
+
+  (void) menv;
+  return list(tree_bind_s,
+              list(retval, mbytes, gcbytes, msecs, nao),
+              cons(prof_s, rest(form)),
+              list(format_s, t, lit("malloc bytes:  ~12a\n"
+                                    "gc heap bytes: ~12a\n"
+                                    "total:         ~12a\n"
+                                    "milliseconds:  ~12a\n"),
+                   mbytes, gcbytes,
+                   list(plus_s, mbytes, gcbytes, nao),
+                   msecs, nao),
+              retval,
+              nao);
+}
 
 val expand_forms(val form, val menv)
 {
@@ -3085,6 +3119,7 @@ void eval_init(void)
   with_saved_vars_s = intern(lit("with-saved-vars"), system_package);
   whole_k = intern(lit("whole"), keyword_package);
   special_s = intern(lit("special"), system_package);
+  prof_s = intern(lit("prof"), user_package);
 
   reg_op(quote_s, op_quote);
   reg_op(qquote_s, op_qquote_error);
@@ -3134,6 +3169,7 @@ void eval_init(void)
   reg_op(quasi_s, op_quasi_lit);
   reg_op(catch_s, op_catch);
   reg_op(with_saved_vars_s, op_with_saved_vars);
+  reg_op(prof_s, op_prof);
 
   reg_mac(gen_s, me_gen);
   reg_mac(gun_s, me_gun);
@@ -3142,6 +3178,7 @@ void eval_init(void)
   reg_mac(do_s, me_op);
   reg_mac(qquote_s, me_qquote);
   reg_mac(sys_qquote_s, me_qquote);
+  reg_mac(intern(lit("pprof"), user_package), me_pprof);
 
   reg_fun(cons_s, func_n2(cons));
   reg_fun(intern(lit("make-lazy-cons"), user_package), func_n1(make_lazy_cons));
@@ -3220,7 +3257,7 @@ void eval_init(void)
   reg_fun(intern(lit("eql"), user_package), eql_f);
   reg_fun(intern(lit("equal"), user_package), equal_f);
 
-  reg_fun(intern(lit("+"), user_package), func_n0v(plusv));
+  reg_fun(plus_s = intern(lit("+"), user_package), func_n0v(plusv));
   reg_fun(intern(lit("-"), user_package), func_n1v(minusv));
   reg_fun(intern(lit("*"), user_package), func_n0v(mulv));
   reg_fun(intern(lit("abs"), user_package), func_n1(abso));
diff --git a/gc.c b/gc.c
index 3686cd32..44ee97c6 100644
--- a/gc.c
+++ b/gc.c
@@ -75,6 +75,8 @@ static val free_list, *free_tail = &free_list;
 static heap_t *heap_list;
 static val heap_min_bound, heap_max_bound;
 
+alloc_bytes_t gc_bytes;
+
 int gc_enabled = 1;
 
 #if CONFIG_GEN_GC
@@ -120,7 +122,7 @@ void protect(val *first, ...)
 
 static void more(void)
 {
-  heap_t *heap = (heap_t *) chk_malloc(sizeof *heap);
+  heap_t *heap = (heap_t *) chk_malloc_gc_more(sizeof *heap);
   obj_t *block = heap->block, *end = heap->block + HEAP_SIZE;
 
   if (end > heap_max_bound)
@@ -178,6 +180,7 @@ val make_obj(void)
       ret->t.gen = 0;
       freshobj[freshobj_idx++] = ret;
 #endif
+      gc_bytes += sizeof (obj_t);
       return ret;
     }
 
diff --git a/genvim.txr b/genvim.txr
index e2ff77e1..c134884e 100644
--- a/genvim.txr
+++ b/genvim.txr
@@ -22,7 +22,7 @@ static void dir_tables_init(void)
 @    (or)
   reg_mac(intern(lit("@{txl-sym}")@(skip)
 @    (or)
-  reg_fun(intern(lit("@{txl-sym}")@(skip)
+  reg_fun(@(skip)intern(lit("@{txl-sym}")@(skip)
 @    (or)
   reg_fun(@{txl-sym}_s,@(skip)
 @    (or)
diff --git a/lib.c b/lib.c
index 839dc116..e7fa9ff9 100644
--- a/lib.c
+++ b/lib.c
@@ -1287,6 +1287,8 @@ val equal(val left, val right)
 
 static mem_t *malloc_low_bound, *malloc_high_bound;
 
+alloc_bytes_t malloc_bytes;
+
 mem_t *chk_malloc(size_t size)
 {
   mem_t *ptr = (mem_t *) malloc(size);
@@ -1299,23 +1301,35 @@ mem_t *chk_malloc(size_t size)
     malloc_low_bound = ptr;
   else if (ptr + size > malloc_high_bound)
     malloc_high_bound = ptr + size;
+  malloc_bytes += size;
+  return ptr;
+}
+
+mem_t *chk_malloc_gc_more(size_t size)
+{
+  mem_t *ptr = (mem_t *) malloc(size);
+  assert (!async_sig_enabled);
+  if (size && ptr == 0)
+    ptr = (mem_t *) oom_realloc(0, size);
   return ptr;
 }
 
 mem_t *chk_calloc(size_t n, size_t size)
 {
   mem_t *ptr = (mem_t *) calloc(n, size);
+  cnum total = (cnum) size * (cnum) n;
 
   assert (!async_sig_enabled);
 
   if (size && ptr == 0) {
-    ptr = (mem_t *) oom_realloc(0, size);
-    memset(ptr, 0, n * size);
+    ptr = (mem_t *) oom_realloc(0, total);
+    memset(ptr, 0, total);
   }
   if (ptr < malloc_low_bound)
     malloc_low_bound = ptr;
   else if (ptr + size > malloc_high_bound)
-    malloc_high_bound = ptr + size;
+    malloc_high_bound = ptr + total;
+  malloc_bytes += total;
   return ptr;
 }
 
@@ -1331,6 +1345,7 @@ mem_t *chk_realloc(mem_t *old, size_t size)
     malloc_low_bound = newptr;
   else if (newptr + size > malloc_high_bound)
     malloc_high_bound = newptr + size;
+  malloc_bytes += size;
   return newptr;
 }
 
diff --git a/lib.h b/lib.h
index c1524891..5d7c694c 100644
--- a/lib.h
+++ b/lib.h
@@ -358,6 +358,15 @@ extern val prog_string;
 
 extern mem_t *(*oom_realloc)(mem_t *, size_t);
 
+#if HAVE_ULONGLONG_T 
+typedef ulonglong_t alloc_bytes_t;
+#else
+typedef unsigned long alloc_bytes_t;
+#endif
+
+extern alloc_bytes_t malloc_bytes;
+extern alloc_bytes_t gc_bytes;
+
 val identity(val obj);
 val typeof(val obj);
 val type_check(val obj, int);
@@ -426,6 +435,7 @@ val none_satisfy(val list, val pred, val key);
 val eql(val left, val right);
 val equal(val left, val right);
 mem_t *chk_malloc(size_t size);
+mem_t *chk_malloc_gc_more(size_t size);
 mem_t *chk_calloc(size_t n, size_t size);
 mem_t *chk_realloc(mem_t *, size_t size);
 int in_malloc_range(mem_t *);
diff --git a/stream.c b/stream.c
index 85c16d80..8e049212 100644
--- a/stream.c
+++ b/stream.c
@@ -71,6 +71,7 @@ val gid_k, rdev_k, size_k, blksize_k, blocks_k;
 val atime_k, mtime_k, ctime_k;
 val from_start_k, from_current_k, from_end_k;
 val real_time_k, name_k;
+val format_s;
 
 static void common_destroy(val obj)
 {
@@ -2624,6 +2625,7 @@ void stream_init(void)
   from_end_k = intern(lit("from-end"), keyword_package);
   real_time_k = intern(lit("real-time"), keyword_package);
   name_k = intern(lit("name"), keyword_package);
+  format_s = intern(lit("format"), user_package);
 
 #ifndef S_IFSOCK
 #define S_IFSOCK 0
@@ -2714,7 +2716,7 @@ void stream_init(void)
   reg_var(stdnull_s = intern(lit("*stdnull*"), user_package),
           make_null_stream());
 
-  reg_fun(intern(lit("format"), user_package), func_n2v(formatv));
+  reg_fun(format_s, func_n2v(formatv));
   reg_fun(intern(lit("make-string-input-stream"), user_package), func_n1(make_string_input_stream));
   reg_fun(intern(lit("make-string-byte-input-stream"), user_package), func_n1(make_string_byte_input_stream));
   reg_fun(intern(lit("make-string-output-stream"), user_package), func_n0(make_string_output_stream));
diff --git a/stream.h b/stream.h
index edd1acc4..388f9cc4 100644
--- a/stream.h
+++ b/stream.h
@@ -61,6 +61,7 @@ extern val gid_k, rdev_k, size_k, blksize_k, blocks_k;
 extern val atime_k, mtime_k, ctime_k;
 extern val from_start_k, from_current_k, from_end_k;
 extern val real_time_k, name_k;
+extern val format_s;
 
 extern val stdin_s, stdout_s, stddebug_s, stderr_s, stdnull_s;
 
diff --git a/txr.1 b/txr.1
index b34ba7cf..b3908121 100644
--- a/txr.1
+++ b/txr.1
@@ -14026,6 +14026,66 @@ source code location info also, so that when the TXR Lisp evaluator
 encounters errors in transformed code, it can give diagnostics which refer
 to the original untransformed source code.
 
+.SH PROFILING
+
+.SS Operator prof
+
+.TP
+Syntax:
+
+  (prof <form>*)
+
+.TP
+Description:
+
+The prof operator evaluates the enclosed forms from left to right similarly
+to progn, while determining the memory allocation requests and time
+consumed by the evaluation of the forms.  
+
+If there are no forms, the prof operator measures the smallest measurable
+operation of evaluating nothing and producing nil.
+
+If the evaluation terminates normally (not abruptly by a non-local
+control transfer), then prof yields a list consisting of:
+
+  (<value> <malloc-bytes> <gc-bytes> <milliseconds>)
+
+where <values> is the value returned by the rightmost <form>, or nil if there
+are no forms, <malloc-bytes> is the total number of bytes of all malloc
+requests (or at least those known to the TXR runtime, such as those of all
+internal objects), <gc-bytes> is the total number of bytes drawn from the
+garbage-collected heaps, and <milliseconds> is the total processor time
+consumed over the execution of those forms.
+
+Notes:
+
+The bytes allocated by the garbage collector from malloc to create
+heap areas are not counted as <malloc-bytes>. <malloc-bytes> includes storage
+such as the space used for dynamic strings, vectors and bignums (in addition to
+their gc-heap allocated nodes), and the various structures used by the cobj
+type objects such as streams and hashes. Objects in external libraries that use
+un-instrumented allocators are not counted: for instance the C FILE * streams.
+
+.SS Macro pprof
+
+.TP
+Syntax:
+
+  (pprof <form>*)
+
+.TP
+Description:
+
+The pprof (pretty-printing prof) macro is similar to progn. It evaluates forms,
+and returns the rightmost one, or nil if there are no forms.
+
+Over the evaluation of the forms, it counts memory allocations, and measures
+CPU time. If the forms terminate normally, then just prior to returning,
+pprof prints these statistics are printed in a concise report on the
+*std-output* stream, prior to returning the value or nil.
+
+The pprof macro relies on the prof operator.
+
 .SH MODULARIZATION
 
 .SS Special variable *self-path*
diff --git a/txr.vim b/txr.vim
index dc68e64c..f0d07ba8 100644
--- a/txr.vim
+++ b/txr.vim
@@ -116,57 +116,57 @@ syn keyword txl_keyword contained open-pipe open-process open-tail openlog
 syn keyword txl_keyword contained or orf packagep perm
 syn keyword txl_keyword contained pop pos pos-if posq
 syn keyword txl_keyword contained posql posqual pprinl pprint
-syn keyword txl_keyword contained prinl print prog1 progn
-syn keyword txl_keyword contained prop proper-listp push pushhash
-syn keyword txl_keyword contained put-byte put-char put-line put-string
-syn keyword txl_keyword contained pwd qquote quasi quote
-syn keyword txl_keyword contained rand random random-fixnum random-state-p
-syn keyword txl_keyword contained range range* rcomb read
-syn keyword txl_keyword contained readlink real-time-stream-p reduce-left reduce-right
-syn keyword txl_keyword contained ref refset regex-compile regex-parse
-syn keyword txl_keyword contained regexp regsub rehome-sym remhash
-syn keyword txl_keyword contained remove-if remove-if* remove-path remq
-syn keyword txl_keyword contained remq* remql remql* remqual
-syn keyword txl_keyword contained remqual* rename-path repeat replace
-syn keyword txl_keyword contained replace-list replace-str replace-vec rest
-syn keyword txl_keyword contained return return-from reverse rlcp
-syn keyword txl_keyword contained rperm rplaca rplacd s-ifblk
-syn keyword txl_keyword contained s-ifchr s-ifdir s-ififo s-iflnk
-syn keyword txl_keyword contained s-ifmt s-ifreg s-ifsock s-irgrp
-syn keyword txl_keyword contained s-iroth s-irusr s-irwxg s-irwxo
-syn keyword txl_keyword contained s-irwxu s-isgid s-isuid s-isvtx
-syn keyword txl_keyword contained s-iwgrp s-iwoth s-iwusr s-ixgrp
-syn keyword txl_keyword contained s-ixoth s-ixusr search-regex search-str
-syn keyword txl_keyword contained search-str-tree second seek-stream set
-syn keyword txl_keyword contained set-diff set-hash-userdata set-sig-handler sethash
-syn keyword txl_keyword contained setlogmask sig-abrt sig-alrm sig-bus
-syn keyword txl_keyword contained sig-check sig-chld sig-cont sig-fpe
-syn keyword txl_keyword contained sig-hup sig-ill sig-int sig-io
-syn keyword txl_keyword contained sig-iot sig-kill sig-lost sig-pipe
-syn keyword txl_keyword contained sig-poll sig-prof sig-pwr sig-quit
-syn keyword txl_keyword contained sig-segv sig-stkflt sig-stop sig-sys
-syn keyword txl_keyword contained sig-term sig-trap sig-tstp sig-ttin
-syn keyword txl_keyword contained sig-ttou sig-urg sig-usr1 sig-usr2
-syn keyword txl_keyword contained sig-vtalrm sig-winch sig-xcpu sig-xfsz
-syn keyword txl_keyword contained sin sixth size-vec some
-syn keyword txl_keyword contained sort source-loc source-loc-str span-str
-syn keyword txl_keyword contained splice split-str split-str-set sqrt
-syn keyword txl_keyword contained stat stream-get-prop stream-set-prop streamp
-syn keyword txl_keyword contained string-cmp string-extend string-lt stringp
-syn keyword txl_keyword contained sub sub-list sub-str sub-vec
-syn keyword txl_keyword contained symacrolet symbol-function symbol-name symbol-package
-syn keyword txl_keyword contained symbol-value symbolp symlink sys-qquote
-syn keyword txl_keyword contained sys-splice sys-unquote syslog tan
-syn keyword txl_keyword contained third throw throwf time
-syn keyword txl_keyword contained time-fields-local time-fields-utc time-string-local time-string-utc
-syn keyword txl_keyword contained time-usec tok-str tostring tostringp
-syn keyword txl_keyword contained tree-bind tree-case tree-find trie-add
-syn keyword txl_keyword contained trie-compress trim-str trunc typeof
-syn keyword txl_keyword contained unget-byte unget-char unquote upcase-str
-syn keyword txl_keyword contained update url-decode url-encode usleep
-syn keyword txl_keyword contained uw-protect vec vec-push vec-set-length
-syn keyword txl_keyword contained vecref vector vector-list vectorp
-syn keyword txl_keyword contained with-saved-vars zerop
+syn keyword txl_keyword contained pprof prinl print prof
+syn keyword txl_keyword contained prog1 progn prop proper-listp
+syn keyword txl_keyword contained push pushhash put-byte put-char
+syn keyword txl_keyword contained put-line put-string pwd qquote
+syn keyword txl_keyword contained quasi quote rand random
+syn keyword txl_keyword contained random-fixnum random-state-p range range*
+syn keyword txl_keyword contained rcomb read readlink real-time-stream-p
+syn keyword txl_keyword contained reduce-left reduce-right ref refset
+syn keyword txl_keyword contained regex-compile regex-parse regexp regsub
+syn keyword txl_keyword contained rehome-sym remhash remove-if remove-if*
+syn keyword txl_keyword contained remove-path remq remq* remql
+syn keyword txl_keyword contained remql* remqual remqual* rename-path
+syn keyword txl_keyword contained repeat replace replace-list replace-str
+syn keyword txl_keyword contained replace-vec rest return return-from
+syn keyword txl_keyword contained reverse rlcp rperm rplaca
+syn keyword txl_keyword contained rplacd s-ifblk s-ifchr s-ifdir
+syn keyword txl_keyword contained s-ififo s-iflnk s-ifmt s-ifreg
+syn keyword txl_keyword contained s-ifsock s-irgrp s-iroth s-irusr
+syn keyword txl_keyword contained s-irwxg s-irwxo s-irwxu s-isgid
+syn keyword txl_keyword contained s-isuid s-isvtx s-iwgrp s-iwoth
+syn keyword txl_keyword contained s-iwusr s-ixgrp s-ixoth s-ixusr
+syn keyword txl_keyword contained search-regex search-str search-str-tree second
+syn keyword txl_keyword contained seek-stream set set-diff set-hash-userdata
+syn keyword txl_keyword contained set-sig-handler sethash setlogmask sig-abrt
+syn keyword txl_keyword contained sig-alrm sig-bus sig-check sig-chld
+syn keyword txl_keyword contained sig-cont sig-fpe sig-hup sig-ill
+syn keyword txl_keyword contained sig-int sig-io sig-iot sig-kill
+syn keyword txl_keyword contained sig-lost sig-pipe sig-poll sig-prof
+syn keyword txl_keyword contained sig-pwr sig-quit sig-segv sig-stkflt
+syn keyword txl_keyword contained sig-stop sig-sys sig-term sig-trap
+syn keyword txl_keyword contained sig-tstp sig-ttin sig-ttou sig-urg
+syn keyword txl_keyword contained sig-usr1 sig-usr2 sig-vtalrm sig-winch
+syn keyword txl_keyword contained sig-xcpu sig-xfsz sin sixth
+syn keyword txl_keyword contained size-vec some sort source-loc
+syn keyword txl_keyword contained source-loc-str span-str splice split-str
+syn keyword txl_keyword contained split-str-set sqrt stat stream-get-prop
+syn keyword txl_keyword contained stream-set-prop streamp string-cmp string-extend
+syn keyword txl_keyword contained string-lt stringp sub sub-list
+syn keyword txl_keyword contained sub-str sub-vec symacrolet symbol-function
+syn keyword txl_keyword contained symbol-name symbol-package symbol-value symbolp
+syn keyword txl_keyword contained symlink sys-qquote sys-splice sys-unquote
+syn keyword txl_keyword contained syslog tan third throw
+syn keyword txl_keyword contained throwf time time-fields-local time-fields-utc
+syn keyword txl_keyword contained time-string-local time-string-utc time-usec tok-str
+syn keyword txl_keyword contained tostring tostringp tree-bind tree-case
+syn keyword txl_keyword contained tree-find trie-add trie-compress trim-str
+syn keyword txl_keyword contained trunc typeof unget-byte unget-char
+syn keyword txl_keyword contained unquote upcase-str update url-decode
+syn keyword txl_keyword contained url-encode usleep uw-protect vec
+syn keyword txl_keyword contained vec-push vec-set-length vecref vector
+syn keyword txl_keyword contained vector-list vectorp with-saved-vars zerop
 
 syn match txr_error "@[\t ]*[*]\?[\t ]*."
 syn match txr_nested_error "[^\t `]\+" contained