(let ((*profiles* (table)))
  (set-top-level-value! 'profile
        (λ (s)
          (let ((f (top-level-value s)))
            (put! *profiles* s (cons 0 0))
            (set-top-level-value! s
             (λ args
               (def tt (get *profiles* s))
               (def count (car tt))
               (def time  (cdr tt))
               (def t0 (time-now))
               (def v (apply f args))
               (set-cdr! tt (+ time (- (time-now) t0)))
               (set-car! tt (+ count 1))
               v)))))
  (set-top-level-value! 'show-profiles
        (λ ()
          (def pr (filter (λ (x) (> (cadr x) 0))
                             (table->assoc-list *profiles*)))
          (def width (+ 4
                           (apply max
                                  (map (λ (x)
                                         (length (str x)))
                                       (cons 'Function
                                             (map car pr))))))
          (princ (str-pad "Function" width)
                 "#Calls     Time (seconds)")
          (newline)
          (princ (str-pad "--------" width)
                 "------     --------------")
          (newline)
          (for-each
           (λ (p)
             (princ (str-pad (str (caddr p)) width)
                    (str-pad (str (cadr p)) 11)
                    (/ (car p) 1000000000))
             (newline))
           (simple-sort (map (λ (l) (reverse (to-proper l)))
                             pr)))))
  (set-top-level-value! 'clear-profiles
        (λ ()
          (for-each (λ (k)
                      (put! *profiles* k (cons 0 0)))
                    (table-keys *profiles*)))))

(for-each profile
          '(emit encode-byte-code const-to-idx-vec
            lookup-sym in-env? any every
            compile-sym compile-if compile-begin
            compile-arglist macroexpand builtin->instruction
            compile-app nconc get-defined-vars
            compile-in compile compile-f remove-duplicates
            map length> length= count filter append
            last-cdr to-proper reverse reverse! list->vec
            nthcdr assq memq assoc member
            assv memv nreconc bq-process))