(declare (block) (standard-bindings) (extended-bindings))
(begin
  (define std/debug/heap#memory-usage
    (lambda ()
      (let ((_stats750_ (let () (declare (not safe)) (##process-statistics))))
        (cons (cons 'gc-heap-size
                    (inexact->exact (f64vector-ref _stats750_ '15)))
              (cons (cons 'gc-alloc
                          (inexact->exact (f64vector-ref _stats750_ '16)))
                    (cons (cons 'gc-live
                                (inexact->exact
                                 (f64vector-ref _stats750_ '17)))
                          (cons (cons 'gc-movable
                                      (inexact->exact
                                       (f64vector-ref _stats750_ '18)))
                                (cons (cons 'gc-still
                                            (inexact->exact
                                             (f64vector-ref _stats750_ '19)))
                                      '()))))))))
  (define std/debug/heap#heap-type-stats
    (lambda ()
      (let* ((_live740_
              (std/debug/heap#walk-heap!__% '#f absent-value absent-value))
             (_types742_ (make-table 'test: eq?)))
        (table-for-each
         (lambda (_obj745_ _g4349_)
           (let ((_t747_ (std/generic/dispatch#type-of _obj745_)))
             (hash-update! _types742_ _t747_ 1+ '0)))
         _live740_)
        (values (table-length _live740_) _types742_))))
  (define std/debug/heap#dump-heap-stats!__%
    (lambda (_port652_)
      (let () (declare (not safe)) (##gc))
      (let* ((_mem654_ (std/debug/heap#memory-usage))
             (_g4350_ (std/debug/heap#count-still1)))
        (begin
          (let ((_g4351_ (let ()
                           (declare (not safe))
                           (if (##values? _g4350_)
                               (##vector-length _g4350_)
                               1))))
            (if (not (let () (declare (not safe)) (##fx= _g4351_ 2)))
                (error "Context expects 2 values" _g4351_)))
          (let ((_still656_
                 (let () (declare (not safe)) (##vector-ref _g4350_ 0)))
                (_refcounted657_
                 (let () (declare (not safe)) (##vector-ref _g4350_ 1))))
            (let ((_g4352_ (std/debug/heap#heap-type-stats)))
              (begin
                (let ((_g4353_ (let ()
                                 (declare (not safe))
                                 (if (##values? _g4352_)
                                     (##vector-length _g4352_)
                                     1))))
                  (if (not (let () (declare (not safe)) (##fx= _g4353_ 2)))
                      (error "Context expects 2 values" _g4353_)))
                (let ((_count659_
                       (let () (declare (not safe)) (##vector-ref _g4352_ 0)))
                      (_types660_
                       (let () (declare (not safe)) (##vector-ref _g4352_ 1))))
                  (let ()
                    (call-with-parameters
                     (lambda ()
                       (displayln '"=== memory usage ===")
                       (for-each
                        (lambda (_e663665_)
                          (let* ((_g667674_ _e663665_)
                                 (_E669678_
                                  (lambda ()
                                    (error '"No clause matching" _g667674_)))
                                 (_K670684_
                                  (lambda (_val681_ _key682_)
                                    (displayln _key682_ '": " _val681_))))
                            (if (let ()
                                  (declare (not safe))
                                  (##pair? _g667674_))
                                (let ((_hd671687_
                                       (let ()
                                         (declare (not safe))
                                         (##car _g667674_)))
                                      (_tl672689_
                                       (let ()
                                         (declare (not safe))
                                         (##cdr _g667674_))))
                                  (let* ((_key692_ _hd671687_)
                                         (_val694_ _tl672689_))
                                    (_K670684_ _val694_ _key692_)))
                                (_E669678_))))
                        _mem654_)
                       (displayln '"=== heap summary ===")
                       (displayln '"objects: " _count659_)
                       (displayln '"still: " _still656_)
                       (displayln '"refcounted: " _refcounted657_)
                       (displayln '"=== heap type counts ===")
                       (for-each
                        (lambda (_e695697_)
                          (let* ((_g699706_ _e695697_)
                                 (_E701710_
                                  (lambda ()
                                    (error '"No clause matching" _g699706_)))
                                 (_K702716_
                                  (lambda (_val713_ _key714_)
                                    (displayln _key714_ '" " _val713_))))
                            (if (let ()
                                  (declare (not safe))
                                  (##pair? _g699706_))
                                (let ((_hd703719_
                                       (let ()
                                         (declare (not safe))
                                         (##car _g699706_)))
                                      (_tl704721_
                                       (let ()
                                         (declare (not safe))
                                         (##cdr _g699706_))))
                                  (let* ((_key724_ _hd703719_)
                                         (_val726_ _tl704721_))
                                    (_K702716_ _val726_ _key724_)))
                                (_E701710_))))
                        (std/sort#sort
                         (table->list _types660_)
                         (lambda (_a728_ _b729_)
                           (> (cdr _a728_) (cdr _b729_))))))
                     current-output-port
                     _port652_))))))))))
  (define std/debug/heap#dump-heap-stats!__0
    (lambda ()
      (let ((_port735_ (current-error-port)))
        (std/debug/heap#dump-heap-stats!__% _port735_))))
  (define std/debug/heap#dump-heap-stats!
    (lambda _g4355_
      (let ((_g4354_ (let () (declare (not safe)) (##length _g4355_))))
        (cond ((let () (declare (not safe)) (##fx= _g4354_ 0))
               (apply std/debug/heap#dump-heap-stats!__0 _g4355_))
              ((let () (declare (not safe)) (##fx= _g4354_ 1))
               (apply std/debug/heap#dump-heap-stats!__% _g4355_))
              (else
               (##raise-wrong-number-of-arguments-exception
                std/debug/heap#dump-heap-stats!
                _g4355_))))))
  (define std/debug/heap#count-still (lambda () (std/debug/heap#count-still1)))
  (define std/debug/heap#count-still1
    (lambda ()
      (let ((_still647_ (std/debug/heap#count-still-objects))
            (_refcounted648_ (std/debug/heap#count-still-objects/refcount)))
        (values _still647_ _refcounted648_))))
  (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 (_countf641_ _getf642_)
      (std/debug/heap#get-still1 _countf641_ _getf642_)))
  (define std/debug/heap#get-still1
    (lambda (_countf631_ _getf632_)
      (let ((_count634_ (_countf631_)))
        (if (fx> _count634_ '0)
            (let* ((_vec636_ (make-vector (fx+ _count634_ '1)))
                   (_count638_ (_getf632_ _vec636_)))
              (if (fx< _count638_ (vector-length _vec636_))
                  (vector-shrink! _vec636_ _count638_)
                  '#!void)
              _vec636_)
            '#()))))
  (define std/debug/heap#walk-heap!__%
    (lambda (_g4356_ _walk596600_ _root597602_)
      (let* ((_walk605_ (if (eq? _walk596600_ absent-value) '#f _walk596600_))
             (_root607_ (if (eq? _root597602_ absent-value) '#f _root597602_))
             (_seen609_ (make-table 'test: eq?)))
        (letrec ((_visit611_
                  (lambda (_container613_ _i614_ _obj615_)
                    (if (table-ref _seen609_ _obj615_ '#f)
                        absent-obj
                        (if (eq? _seen609_ _obj615_)
                            absent-obj
                            (if (let ()
                                  (declare (not safe))
                                  (##mem-allocated? _obj615_))
                                (begin
                                  (table-set! _seen609_ _obj615_ '#t)
                                  (if _walk605_
                                      (_walk605_
                                       _container613_
                                       _i614_
                                       _obj615_)
                                      '#f))
                                '#f))))))
          (if _root607_
              (std/debug/heap#walk-from-object! _root607_ _visit611_)
              (std/debug/heap#walk-from-roots! _visit611_))
          _seen609_))))
  (define std/debug/heap#walk-heap!__@
    (lambda (_keys595620_ . _args622_)
      (apply std/debug/heap#walk-heap!__%
             _keys595620_
             (table-ref _keys595620_ 'walk: absent-value)
             (table-ref _keys595620_ 'root: absent-value)
             _args622_)))
  (define std/debug/heap#walk-heap!
    (lambda _args598628_
      (apply keyword-dispatch
             '#(walk: root:)
             std/debug/heap#walk-heap!__@
             _args598628_)))
  (define std/debug/heap#walk-from-roots!
    (lambda (_visit574_)
      (letrec ((_scan-symbol-and-global-var576_
                (lambda (_obj584_)
                  (let ((_$e586_ (std/debug/heap#walk-from-object!
                                  _obj584_
                                  _visit574_)))
                    (if _$e586_
                        _$e586_
                        (if (let ()
                              (declare (not safe))
                              (##global-var? _obj584_))
                            (let* ((_var589_
                                    (let ()
                                      (declare (not safe))
                                      (##make-global-var _obj584_)))
                                   (_val591_
                                    (let ()
                                      (declare (not safe))
                                      (##global-var-ref _obj584_))))
                              (std/debug/heap#walk-from-object!
                               _val591_
                               _visit574_))
                            '#f)))))
               (_scan-keyword577_
                (lambda (_obj582_)
                  (std/debug/heap#walk-from-object! _obj582_ _visit574_)))
               (_scan-still578_
                (lambda (_obj580_)
                  (std/debug/heap#walk-from-object! _obj580_ _visit574_))))
        (std/debug/heap#walk-interned-symbols! _scan-symbol-and-global-var576_)
        (std/debug/heap#walk-interned-keywords! _scan-keyword577_)
        (std/debug/heap#walk-still-objects! _scan-still578_))))
  (define std/debug/heap#walk-still-objects!
    (lambda (_scan563_)
      (let* ((_still565_ (std/debug/heap#still-objects/refcount))
             (_count567_ (vector-length _still565_)))
        (let _lp570_ ((_i572_ '0))
          (if (fx< _i572_ _count567_)
              (begin
                (_scan563_
                 (let ()
                   (declare (not safe))
                   (##vector-ref _still565_ _i572_)))
                (_lp570_ (fx+ _i572_ '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);")))
