(declare (block) (standard-bindings) (extended-bindings))
(begin
  (define std/debug/heap#memory-usage
    (lambda ()
      (let ((_stats40986_ (##process-statistics)))
        (cons (cons 'gc-heap-size
                    (inexact->exact (f64vector-ref _stats40986_ '15)))
              (cons (cons 'gc-alloc
                          (inexact->exact (f64vector-ref _stats40986_ '16)))
                    (cons (cons 'gc-live
                                (inexact->exact
                                 (f64vector-ref _stats40986_ '17)))
                          (cons (cons 'gc-movable
                                      (inexact->exact
                                       (f64vector-ref _stats40986_ '18)))
                                (cons (cons 'gc-still
                                            (inexact->exact
                                             (f64vector-ref _stats40986_ '19)))
                                      '()))))))))
  (define std/debug/heap#heap-type-stats
    (lambda ()
      (let* ((_live40976_
              (std/debug/heap#walk-heap!__% '#f absent-value absent-value))
             (_types40978_ (make-table 'test: eq?)))
        (table-for-each
         (lambda (_obj40981_ _g40987_)
           (let ((_t40983_ (std/generic/dispatch#type-of _obj40981_)))
             (hash-update! _types40978_ _t40983_ 1+ '0)))
         _live40976_)
        (values (table-length _live40976_) _types40978_))))
  (define std/debug/heap#dump-heap-stats!__%
    (lambda (_port40888_)
      (##gc)
      (let* ((_mem40890_ (std/debug/heap#memory-usage))
             (_g40988_ (std/debug/heap#count-still1)))
        (begin
          (let ((_g40989_
                 (if (##values? _g40988_) (##vector-length _g40988_) 1)))
            (if (not (##fx= _g40989_ 2))
                (error "Context expects 2 values" _g40989_)))
          (let ((_still40892_ (##vector-ref _g40988_ 0))
                (_refcounted40893_ (##vector-ref _g40988_ 1)))
            (let ((_g40990_ (std/debug/heap#heap-type-stats)))
              (begin
                (let ((_g40991_
                       (if (##values? _g40990_) (##vector-length _g40990_) 1)))
                  (if (not (##fx= _g40991_ 2))
                      (error "Context expects 2 values" _g40991_)))
                (let ((_count40895_ (##vector-ref _g40990_ 0))
                      (_types40896_ (##vector-ref _g40990_ 1)))
                  (let ()
                    (call-with-parameters
                     (lambda ()
                       (displayln '"=== memory usage ===")
                       (for-each
                        (lambda (_e4089940901_)
                          (let* ((_g4090340910_ _e4089940901_)
                                 (_E4090540914_
                                  (lambda ()
                                    (error '"No clause matching"
                                           _g4090340910_)))
                                 (_K4090640920_
                                  (lambda (_val40917_ _key40918_)
                                    (displayln _key40918_ '": " _val40917_))))
                            (if (##pair? _g4090340910_)
                                (let ((_hd4090740923_ (##car _g4090340910_))
                                      (_tl4090840925_ (##cdr _g4090340910_)))
                                  (let* ((_key40928_ _hd4090740923_)
                                         (_val40930_ _tl4090840925_))
                                    (_K4090640920_ _val40930_ _key40928_)))
                                (_E4090540914_))))
                        _mem40890_)
                       (displayln '"=== heap summary ===")
                       (displayln '"objects: " _count40895_)
                       (displayln '"still: " _still40892_)
                       (displayln '"refcounted: " _refcounted40893_)
                       (displayln '"=== heap type counts ===")
                       (for-each
                        (lambda (_e4093140933_)
                          (let* ((_g4093540942_ _e4093140933_)
                                 (_E4093740946_
                                  (lambda ()
                                    (error '"No clause matching"
                                           _g4093540942_)))
                                 (_K4093840952_
                                  (lambda (_val40949_ _key40950_)
                                    (displayln _key40950_ '" " _val40949_))))
                            (if (##pair? _g4093540942_)
                                (let ((_hd4093940955_ (##car _g4093540942_))
                                      (_tl4094040957_ (##cdr _g4093540942_)))
                                  (let* ((_key40960_ _hd4093940955_)
                                         (_val40962_ _tl4094040957_))
                                    (_K4093840952_ _val40962_ _key40960_)))
                                (_E4093740946_))))
                        (std/sort#sort
                         (table->list _types40896_)
                         (lambda (_a40964_ _b40965_)
                           (> (cdr _a40964_) (cdr _b40965_))))))
                     current-output-port
                     _port40888_))))))))))
  (define std/debug/heap#dump-heap-stats!__0
    (lambda ()
      (let ((_port40971_ (current-error-port)))
        (std/debug/heap#dump-heap-stats!__% _port40971_))))
  (define std/debug/heap#dump-heap-stats!
    (lambda _g40993_
      (let ((_g40992_ (length _g40993_)))
        (cond ((##fx= _g40992_ 0)
               (apply std/debug/heap#dump-heap-stats!__0 _g40993_))
              ((##fx= _g40992_ 1)
               (apply std/debug/heap#dump-heap-stats!__% _g40993_))
              (else
               (##raise-wrong-number-of-arguments-exception
                std/debug/heap#dump-heap-stats!
                _g40993_))))))
  (define std/debug/heap#count-still (lambda () (std/debug/heap#count-still1)))
  (define std/debug/heap#count-still1
    (lambda ()
      (let ((_still40883_ (std/debug/heap#count-still-objects))
            (_refcounted40884_ (std/debug/heap#count-still-objects/refcount)))
        (values _still40883_ _refcounted40884_))))
  (define std/debug/heap#still-objects/refcount
    (lambda ()
      (std/debug/heap#get-still1
       std/debug/heap#count-still-objects/refcount
       std/debug/heap#get-still-objects/refcount)))
  (define std/debug/heap#still-objects
    (lambda ()
      (std/debug/heap#get-still1
       std/debug/heap#count-still-objects
       std/debug/heap#get-still-objects)))
  (define std/debug/heap#get-still
    (lambda (_countf40877_ _getf40878_)
      (std/debug/heap#get-still1 _countf40877_ _getf40878_)))
  (define std/debug/heap#get-still1
    (lambda (_countf40867_ _getf40868_)
      (let ((_count40870_ (_countf40867_)))
        (if (fx> _count40870_ '0)
            (let* ((_vec40872_ (make-vector (fx+ _count40870_ '1)))
                   (_count40874_ (_getf40868_ _vec40872_)))
              (if (fx< _count40874_ (vector-length _vec40872_))
                  (vector-shrink! _vec40872_ _count40874_)
                  '#!void)
              _vec40872_)
            '#()))))
  (define std/debug/heap#walk-heap!__%
    (lambda (_g40994_ _walk4083240836_ _root4083340838_)
      (let* ((_walk40841_
              (if (eq? _walk4083240836_ absent-value) '#f _walk4083240836_))
             (_root40843_
              (if (eq? _root4083340838_ absent-value) '#f _root4083340838_))
             (_seen40845_ (make-table 'test: eq?)))
        (letrec ((_visit40847_
                  (lambda (_container40849_ _i40850_ _obj40851_)
                    (if (table-ref _seen40845_ _obj40851_ '#f)
                        absent-obj
                        (if (eq? _seen40845_ _obj40851_)
                            absent-obj
                            (if (##mem-allocated? _obj40851_)
                                (begin
                                  (table-set! _seen40845_ _obj40851_ '#t)
                                  (if _walk40841_
                                      (_walk40841_
                                       _container40849_
                                       _i40850_
                                       _obj40851_)
                                      '#f))
                                '#f))))))
          (if _root40843_
              (std/debug/heap#walk-from-object! _root40843_ _visit40847_)
              (std/debug/heap#walk-from-roots! _visit40847_))
          _seen40845_))))
  (define std/debug/heap#walk-heap!__@
    (lambda (_keys4083140856_ . _args40858_)
      (apply std/debug/heap#walk-heap!__%
             _keys4083140856_
             (table-ref _keys4083140856_ 'walk: absent-value)
             (table-ref _keys4083140856_ 'root: absent-value)
             _args40858_)))
  (define std/debug/heap#walk-heap!
    (lambda _args4083440864_
      (apply keyword-dispatch
             '#(walk: root:)
             std/debug/heap#walk-heap!__@
             _args4083440864_)))
  (define std/debug/heap#walk-from-roots!
    (lambda (_visit40810_)
      (letrec ((_scan-symbol-and-global-var40812_
                (lambda (_obj40820_)
                  (let ((_$e40822_
                         (std/debug/heap#walk-from-object!
                          _obj40820_
                          _visit40810_)))
                    (if _$e40822_
                        _$e40822_
                        (if (##global-var? _obj40820_)
                            (let* ((_var40825_ (##make-global-var _obj40820_))
                                   (_val40827_ (##global-var-ref _obj40820_)))
                              (std/debug/heap#walk-from-object!
                               _val40827_
                               _visit40810_))
                            '#f)))))
               (_scan-keyword40813_
                (lambda (_obj40818_)
                  (std/debug/heap#walk-from-object! _obj40818_ _visit40810_)))
               (_scan-still40814_
                (lambda (_obj40816_)
                  (std/debug/heap#walk-from-object! _obj40816_ _visit40810_))))
        (std/debug/heap#walk-interned-symbols!
         _scan-symbol-and-global-var40812_)
        (std/debug/heap#walk-interned-keywords! _scan-keyword40813_)
        (std/debug/heap#walk-still-objects! _scan-still40814_))))
  (define std/debug/heap#walk-still-objects!
    (lambda (_scan40799_)
      (let* ((_still40801_ (std/debug/heap#still-objects/refcount))
             (_count40803_ (vector-length _still40801_)))
        (let _lp40806_ ((_i40808_ '0))
          (if (fx< _i40808_ _count40803_)
              (begin
                (_scan40799_ (##vector-ref _still40801_ _i40808_))
                (_lp40806_ (fx+ _i40808_ '1)))
              '#!void)))))
  (namespace
   ("std/debug/heap#"
    walk-interned-symbols!
    walk-interned-keywords!
    walk-from-object!))
  (define-macro (macro-symbol-next s) `(macro-slot 2 ,s))
  (define-macro (macro-keyword-next k) `(macro-slot 2 ,k))
  (define-macro (macro-walk-seq expr1 expr2) `(or ,expr1 ,expr2))
  (define-macro (macro-walk-continue) `#f)
  (define-macro (macro-walk-no-recursive-scan) `(macro-absent-obj))
  (define-macro (macro-case-type obj)
    `(let ((obj ,obj))
       (if (##not (##mem-allocated? obj))
           (macro-handle-type-atomic)
           (let ((subtype (##subtype obj)))
             (cond ((##fx= subtype (macro-subtype-pair))
                    (macro-handle-type-simple
                     ##cons
                     (##car ##set-car!)
                     (##cdr ##set-cdr!)))
                   ((macro-subtype-ovector? subtype)
                    (macro-handle-type-object-vector ovector))
                   ((##fx= subtype (macro-subtype-foreign))
                    (macro-handle-type-mixed-vector
                     foreign
                     (##foreign-tags ignore)))
                   ((macro-subtype-bvector? subtype)
                    (macro-handle-type-mixed-vector bvector))
                   ((##fx= subtype (macro-subtype-symbol))
                    (macro-handle-type-mixed-vector
                     symbol
                     (##symbol-name ignore)))
                   ((##fx= subtype (macro-subtype-keyword))
                    (macro-handle-type-mixed-vector
                     keyword
                     (##keyword-name ignore)))
                   ((##fx= subtype (macro-subtype-frame))
                    (macro-handle-type-frame))
                   ((##fx= subtype (macro-subtype-continuation))
                    (##continuation-frame obj)
                    (macro-handle-type-simple
                     macro-make-continuation
                     (macro-continuation-frame ignore)
                     (macro-continuation-denv ignore)))
                   ((##fx= subtype (macro-subtype-weak))
                    (if (##will? obj)
                        (macro-handle-type-simple
                         macro-make-will
                         (macro-will-testator ignore)
                         (macro-will-action ignore))
                        (macro-handle-type-object-vector gc-hash-table)))
                   ((##fx= subtype (macro-subtype-procedure))
                    (if (##closure? obj)
                        (macro-handle-type-object-vector closure)
                        (macro-handle-type-atomic)))
                   ((##fx= subtype (macro-subtype-return))
                    (macro-handle-type-atomic))
                   ((##fx= subtype (macro-subtype-promise))
                    (macro-handle-type-object-vector promise))
                   (else (macro-handle-type-atomic)))))))
  (define-macro (macro-walk-object obj)
    `(let ()
       (define (walk-object container i obj)
         (define-macro (macro-handle-type-atomic) `(handle-type-atomic))
         (define (handle-type-atomic) (macro-walk-continue))
         (define-macro (macro-handle-type-object-vector type)
           `(handle-type-object-vector))
         (define (handle-type-object-vector)
           (let ((len (##vector-length obj)))
             (let loop ((i 0))
               (if (##fx< i len)
                   (macro-walk-object-seq
                    obj
                    i
                    (##vector-ref obj i)
                    (loop (##fx+ i 1)))
                   (macro-walk-continue)))))
         (define-macro (macro-handle-type-simple constructor . fields)
           `(macro-handle-fields 0 ,@fields))
         (define-macro (macro-handle-type-mixed-vector type . fields)
           `(macro-handle-fields 0 ,@fields))
         (define-macro (macro-handle-fields i . fields)
           (if (pair? fields)
               (let ((field (car fields)))
                 `(macro-walk-object-seq
                   obj
                   ,i
                   (,(car field) obj)
                   (macro-handle-fields ,(+ i 1) ,@(cdr fields))))
               `(macro-walk-continue)))
         (define-macro (macro-handle-type-frame) `(handle-type-frame))
         (define (handle-type-frame)
           (macro-walk-object-seq
            obj
            0
            (##frame-ret obj)
            (let ((fs (##frame-fs obj)))
              (let loop ((i 1))
                (if (##fx< fs i)
                    (macro-walk-continue)
                    (if (##frame-slot-live? obj i)
                        (macro-walk-object-seq
                         obj
                         i
                         (##frame-ref obj i)
                         (loop (##fx+ i 1)))
                        (loop (##fx+ i 1))))))))
         (macro-walk-visit (macro-case-type obj)))
       (walk-object #t 0 obj)))
  (define (walk-interned-symbols! proc)
    (let ((tbl (##symbol-table)))
      (let loop1 ((i (##fx- (##vector-length tbl) 1)))
        (if (##fx> i 0)
            (let loop2 ((obj (##vector-ref tbl i)))
              (if (##null? obj)
                  (loop1 (##fx- i 1))
                  (macro-walk-seq (proc obj) (loop2 (macro-symbol-next obj)))))
            (macro-walk-continue)))))
  (define (walk-interned-keywords! proc)
    (let ((tbl (##keyword-table)))
      (let loop1 ((i (##fx- (##vector-length tbl) 1)))
        (if (##fx> i 0)
            (let loop2 ((obj (##vector-ref tbl i)))
              (if (##null? obj)
                  (loop1 (##fx- i 1))
                  (macro-walk-seq
                   (proc obj)
                   (loop2 (macro-keyword-next obj)))))
            (macro-walk-continue)))))
  (define (walk-from-object! obj visit)
    (define-macro (macro-walk-visit recursive-scan)
      `(let ((result (visit container i obj)))
         (if (##eq? result (macro-walk-no-recursive-scan))
             (macro-walk-continue)
             (macro-walk-seq result ,recursive-scan))))
    (define-macro (macro-walk-object-seq container i subobject continue)
      `(let* ((container ,container) (i ,i) (subobject ,subobject))
         (macro-walk-seq (walk-object container i subobject) ,continue)))
    (macro-walk-object obj))
  (namespace
   ("std/debug/heap#"
    count-still-objects
    count-still-objects/refcount
    get-still-objects
    get-still-objects/refcount))
  (c-declare
   "// these are defined in gambit/lib/mem.c\n#define ___PSTATE_MEM(var) ___ps->mem.var\n#define still_objs ___PSTATE_MEM(still_objs_)\n#define ___STILL_LINK_OFS 0\n#define ___STILL_REFCOUNT_OFS 1\n#define ___STILL_BODY_OFS 6\n#define ___STILL_HAND_OFS ___STILL_BODY_OFS\n#ifndef ___BODY_OFS\n#define ___BODY_OFS 1\n#endif")
  (define count-still-objects
    (c-lambda
     ()
     int
     "int count = 0;\n___WORD *base = ___CAST(___WORD*,still_objs);\nwhile (base != 0)\n{\n count++;\n base = ___CAST(___WORD*,base[___STILL_LINK_OFS]);\n}\n___return(count);"))
  (define count-still-objects/refcount
    (c-lambda
     ()
     int
     "int count = 0;\n___WORD *base = ___CAST(___WORD*,still_objs);\nwhile (base != 0)\n{\n if (base[___STILL_REFCOUNT_OFS])\n  {\n   count++;\n  }\n base = ___CAST(___WORD*,base[___STILL_LINK_OFS]);\n}\n___return(count);"))
  (define get-still-objects
    (c-lambda
     (scheme-object)
     int
     "int count = 0;\nint max = ___INT(___VECTORLENGTH(___arg1));\n___WORD *base = ___CAST(___WORD*,still_objs);\nwhile (base != 0 && count < max)\n{\n ___SCMOBJ next = ___TAG((base + ___STILL_HAND_OFS - ___BODY_OFS),\n                         (___HD_SUBTYPE(base[___STILL_BODY_OFS-1]) == ___sPAIR?\n                          ___tPAIR : ___tSUBTYPED));\n ___VECTORSET(___arg1, ___FIX(count), next);\n count++;\n base = ___CAST(___WORD*,base[___STILL_LINK_OFS]);\n}\n___return(count);"))
  (define get-still-objects/refcount
    (c-lambda
     (scheme-object)
     int
     "int count = 0;\nint max = ___INT(___VECTORLENGTH(___arg1));\n___WORD *base = ___CAST(___WORD*,still_objs);\nwhile (base != 0 && count < max)\n{\n if (base[___STILL_REFCOUNT_OFS])\n  {\n   ___SCMOBJ next = ___TAG((base + ___STILL_HAND_OFS - ___BODY_OFS),\n                           (___HD_SUBTYPE(base[___STILL_BODY_OFS-1]) == ___sPAIR?\n                            ___tPAIR : ___tSUBTYPED));\n   ___VECTORSET(___arg1, ___FIX(count), next);\n    count++;\n  }\n base = ___CAST(___WORD*,base[___STILL_LINK_OFS]);\n}\n___return(count);")))
