Re: small JSON encoder improvement

just fyi:

testing a native code hack using runtime-compile I can bring it further
down to ~5s:

#!/bin/sh
#| -*- mode: scheme; coding: utf-8; -*-
exec gosh -I. -- $0 "$@"
|#
(use runtime-compile)

(compile-and-load
 `((inline-stub
    (define-cfn encode-string (s::ScmString* port::ScmPort*) ::void :static :inline
      (let* ((body::(const ScmStringBody*) (SCM_STRING_BODY s))
	     (len::ScmSmallInt (SCM_STRING_BODY_LENGTH body))
	     (cp::(const char*) (SCM_STRING_BODY_START body))
	     (ch::ScmChar)
	     (i::int)
	     (ESCAPE_BUF_MAX::(const int) 13)
	     (buf::(.array char (ESCAPE_BUF_MAX)))
	     )
	(SCM_PUTC #\" port)
	(for ((set! i 0) (< i len) (post++ i))
	     (SCM_CHAR_GET cp ch)
	     (case ch
	       ((#\")         (SCM_PUTZ "\\\""    -1 port))
	       ((#\\)         (SCM_PUTZ "\\\\"    -1 port))
	       ((#\backspace) (SCM_PUTZ "\\b"     -1 port))
	       ((#\page)      (SCM_PUTZ "\\f"     -1 port))
	       ((#\newline)   (SCM_PUTZ "\\n"     -1 port))
	       ((#\return)    (SCM_PUTZ "\\r"     -1 port))
	       ((#\tab)       (SCM_PUTZ "\\t"     -1 port))
	       ((#\delete)    (SCM_PUTZ "\\u007f" -1 port))
	       (else
		(cond [(and (or
			     (<= ch 31)
			     (>= ch 128))
			    (< ch #x10000))
		       (snprintf buf ESCAPE_BUF_MAX "\\u%04x" (cast u_int ch))
		       (SCM_PUTZ buf 6 port)]
		      [(>= ch #x10000)
		       (let* ((code::int (- ch #x10000)))
			 (snprintf buf
				   ESCAPE_BUF_MAX
				   "\\u%04x\\u%04x"
				   (logior (>> code 10) #xd800)
				   (logior (logand code #x3ff) #xdc00))
			 (SCM_PUTZ buf 12 port))]
		      [else
		       (SCM_PUTC ch port)])))
	     (set! cp (+ cp (SCM_CHAR_NBYTES ch)))
	     )
	)
      (SCM_PUTC #\" port))

    (define-cfn number-to-string (obj::ScmObj) ::ScmObj :static
      (let* ([fmt::ScmNumberFormat]
             [o::ScmPort* (SCM_PORT (Scm_MakeOutputStringPort TRUE))])
	(Scm_NumberFormatInit (& fmt))
	(set! (ref fmt radix) 10)
	(set! (ref fmt flags) 0)
	(set! (ref fmt precision) -1)
	(Scm_PrintNumber o obj (& fmt))
	(return (Scm_GetOutputString o 0))))
    
    (define-cfn encode-alist (alist port::ScmPort*) ::void :static :inline
      ;; todo: require proper list?
      (SCM_PUTC #\{ port)
      (let* ((i::int 0))
	(for-each (lambda(kv)
		    (if (> i 0)
		      (SCM_PUTC #\, port)
		      (inc! i))
		    ;; todo: x->string?
		    (let* ((key (SCM_CAR kv)))
		      (cond [(SCM_STRINGP key)
			     (encode-string (SCM_STRING key) port)]
			    [(SCM_SYMBOLP key)
			     (encode-string (SCM_STRING (SCM_OBJ (SCM_SYMBOL_NAME key))) port)]
			    [(SCM_NUMBERP key)
			     (encode-string (SCM_STRING (number-to-string key)) port)]
			    [else
			     (Scm_Error "JSON:can't encode key")]))
		    (SCM_PUTC #\: port)
		    (encode (SCM_CDR kv) port))
		  alist)
	(SCM_PUTC #\} port)))

    (define-cfn encode-vector (v port::ScmPort*) ::void :static :inline
      (SCM_PUTC #\[ port)
      (dotimes (i (SCM_VECTOR_SIZE v))
	(when (> i 0)
	  (SCM_PUTC #\, port))
	(encode (SCM_VECTOR_ELEMENT v i) port))
      (SCM_PUTC #\] port))

    (define-cfn encode-number (n port::ScmPort*) ::void :static :inline
      (Scm_Write n (SCM_OBJ port) SCM_WRITE_SIMPLE))

    (define-cfn encode-boolean (b port::ScmPort*) ::void :static :inline
      (if (SCM_TRUEP b)
	(SCM_PUTS (SCM_MAKE_STR "true") port)
	(SCM_PUTS (SCM_MAKE_STR "false") port)))
    
    (define-cfn encode (obj port::ScmPort*) ::void :static :inline
      (cond [(SCM_STRINGP obj)
	     (encode-string (SCM_STRING obj) port)]
	    [(SCM_LISTP obj)
	     (encode-alist obj port)]
	    [(SCM_VECTORP obj)
	     (encode-vector obj port)]
	    [(SCM_NUMBERP obj)
	     (encode-number obj port)]
	    [(SCM_BOOLP obj)
	     (encode-boolean obj port)]
	    [(SCM_EQ obj (SCM_INTERN "true"))
	     (SCM_PUTS (SCM_MAKE_STR "true") port)]
	    [(SCM_EQ obj (SCM_INTERN "false"))
	     (SCM_PUTS (SCM_MAKE_STR "false") port)]
	    [else
	     (Scm_Error "JSON:can't encode obj")]))

    (define-cproc json (obj :optional (port::<output-port> (current-output-port)))
      (encode obj port))
    ))
 '(json)
 :cflags "-O2")

(define (main args)
  (json (read))
  0)