path: root/src/ChezScheme/s/mkgc.ss

;; This file defines the traversal of objects for the GC and similar
;; purposes. The description supports the generatation of multiple C
;; functions, each specialized to a particular traversal mode, while
;; sharing the overall traversal implementation.

;; Roughy the first half of this file is the semi-declarative
;; specification in Parenthe-C, and the second half is the Parenthe-C
;; compiler that generates C code. The lines between the
;; specification, compiler, and supporting C code in "gc.c" are
;; (unfortunately) not very strict.

;; Code is generated by calling the functions listed here:
(disable-unbound-warning
 mkgc-ocd.inc
 mkgc-oce.inc
 mkvfasl.inc)

;; Currently supported traversal modes:
;;   - copy
;;   - sweep
;;   - mark
;;   - self-test   : check immediate pointers only for self references
;;   - size        : immediate size, so does not recur
;;   - measure     : recurs for reachable size
;;   - vfasl-copy
;;   - vfasl-sweep

;; For the specification, there are a few declaration forms described
;; below, such as `trace` to declare a pointer-valued field within an
;; object (to be copied in copy mode and swept in sweep mode).
;; Otherwise, the "declaration" nature of the specification is based
;; on selecting code fragments statically via `case-mode` and
;; `case-flag`. Macros that expand to those forms (e.g., `trace-tlc`)
;; provide a further declarative vaneer.

;; Internals:
(disable-unbound-warning
 trace-base-types
 trace-object-types
 trace-macros)

(define trace-base-types '())
(define trace-object-types '())
(define trace-macros (make-eq-hashtable))

;; This macro just makes sure our main specification has a fixed
;; shape:
(define-syntax define-trace-root
  (syntax-rules (case-type typed-object case-typedfield)
    [(_ (case-type
         [type type-stmt ...]
         ...
         [typed-object
          (case-typefield
           [object-type object-type-stmt ...]
           ...)]))
     (begin
       (set! trace-base-types '((type type-stmt ...) ...))
       (set! trace-object-types '((object-type object-type-stmt ...) ...)))]))

;; A "trace macro" is non-hygienically expanded:
(define-syntax define-trace-macro
  (syntax-rules ()
    [(_ (id arg ...) body ...)
     (eq-hashtable-set! trace-macros 'id '((arg ...) body ...))]))

;; Primitive actions/declarations, must be used as statements in roughly
;; this order (but there are exceptions to the order):
;;  - (space <space>) : target for copy; works as a constraint for other modes
;;  - (vspace <vspace>) : target for vfasl
;;  - (size <size> [<scale>]) : size for copy; skips rest in size mode
;;  - (mark <flag>) : in mark mode, skips rest except counting;
;;      possible <flags>:
;;       * one-bit : record as one bit per segment; inferred when size matches
;;                   alignment or for `space-data`
;;       * within-segment : alloacted within on segment; can be inferred from size
;;       * no-sweep : no need to sweep content (perhaps covered by `trace-now`);
;;                    inferred for `space-data`
;;       * counting-root : check a counting root before pushing to sweep stack
;;  - (trace <field>) : relocate for sweep, copy for copy, recur otherwise
;;  - (trace-early <field>) : relocate for sweep, copy, and mark; recur otherwise
;;  - (trace-now <field>) : direct recur
;;  - (trace-early-rtd <field>) : for record types, avoids recur on #!base-rtd
;;  - (trace-ptrs <field> <count>) : trace an array of pointerrs
;;  - (copy <field>) : copy for copy, ignore otherwise
;;  - (copy-bytes <field> <count>) : copy an array of bytes
;;  - (copy-flonum <field>) : copy flonum and forward
;;  - (copy-flonum* <field>) : copy potentially forwaded flonum
;;  - (copy-type <field>) : copy type from `_` to `_copy_`
;;  - (count <counter> [<size> [<scale> [<modes>]]]) :
;;       uses preceding `size` declaration unless <size>;
;;       normally counts in copy mode, but <modes> can override
;;  - (as-mark-end <statment> ...) : declares that <statement>s implement counting,
;;       which means that it's included for mark mode
;;  - (skip-forwarding) : disable forward-pointer installation in copy mode
;;  - (assert <expr>) : assertion
;;
;; In the above declarations, nonterminals like <space> can be
;; an identifier or a Parenthe-C expression. The meaning of a plain
;; identifier depends on the nonterminal:
;;  - <space>  : should be a `space-...` from cmacro
;;  - <vspace> : should be a `vspace_...`
;;  - <size>   : should be a constant from cmacro
;;  - <field>  : accessor from cmacro, implicitly applied to `_` and `_copy_`

;; Parenthe-C is just what it sounds like: C code written in S-expression
;; form. Use `(<op> <arg> ...)` as usual, and the generated code transforms
;; to infix as appropriate for regonized operators. The statement versus
;; expression distnction is important; primitive declarations must be in
;; statement positions.
;;
;; Statements:
;;  - <expr>
;;  - <declaration> : like `(space <space>)`, etc., above
;;  - (set! <id> <expr>) : renders as `<id> = <expr>;`
;;  - (set! <id> <assign-op> <expr>) : renders as `<id> <assign-op> <expr>;`
;;  - (cond [<expr> <stmt> ...] ... [else <stmt> ...])
;;  - (when <expr> <stmt> ...) : shorthand for `(cond [<expr> <stmt> ...] [else])`
;;  - (while :? <expr> <stmt> ...)
;;  - (do-while <stmt> ... :? <expr>)
;;  - (break)
;;  - (define <id> : <type> <expr>) : discarded if <id> is unused
;;  - (let* ([<id> : <type> <expr>] ...) <stmt> ...)
;;  - (case-mode [<modes> <stmt> ...] ... [else <stmt>]) : static
;;      case dispatch based on mode, where <modes> can be one <mode> or
;;      a parenthesized sequence of <mode>s
;;  - (case-flag <flag> [on <stmt> ...] [off <stmt> ...]) : static dispatch
;;      based on a configuration flag
;;  - (case-space [<space> <stmt> ...] .... [else <stmt> ...]) : run-time
;;      dispatch based on the space of _
;;
;; Expressions:
;;  - <id> : a constant from cmacros or a C name
;;  - <literal> : a literal number or string
;;  - (<field-or-expr> <arg>) : function call, operation use, or field access
;;  - (<field-or-expr> <arg> <arg2>) : function call, operation use, or array
;;      field access
;;  - (<id-or-expr> <arg> <arg> ...) : function call or operation use
;;  - (just <expr>) : same as <expr>, sometimes useful when <expr> is a symbol
;;  - (cond [<expr> <expr>] ... [else <expr>])
;;  - (case-flag <flag> [on <expr>] [off <expr>]) : static dispatch
;;  - (cast <type> <expr>)
;;  - (array-ref <expr> <expr>)
;;
;; Built-in variables:
;;  - _                 : object being copied, swept, etc.
;;  - _copy_            : target in copy or vfasl mode, same as _ otherwise
;;  - _tf_              : type word
;;  - _tg_              : target generation
;;  - _backreferences?_ : dynamic flag indicating whether backreferences are on
;;
;; Stylistically, prefer constants and fields using the hyphenated
;; names from cmacros instead of the corresponding C name. Use C names
;; for derived functions, like `size_record_inst` or `FIX`.

(define-trace-root
  (case-type
   
   [pair
    (case-space
     [space-ephemeron
      (space space-ephemeron)
      (vfasl-fail "ephemeron")
      (size size-ephemeron)
      (copy pair-car)
      (copy pair-cdr)
      (case-mode
       [(copy)
        (set! (ephemeron-prev-ref _copy_) NULL)
        (set! (ephemeron-next _copy_) NULL)]
       [else])
      (add-ephemeron-to-pending)
      (mark one-bit no-sweep)
      (assert-ephemeron-size-ok)
      (count countof-ephemeron)]
     [space-weakpair
      (space space-weakpair)
      (vfasl-fail "weakpair")
      (try-double-pair copy pair-car
                       trace pair-cdr
                       countof-weakpair)]
     [else
      (space space-impure)
      (vspace vspace_impure) 
      (try-double-pair trace pair-car
                       trace pair-cdr
                       countof-pair)])]

   [closure
    (define code : ptr (CLOSCODE _))
    (trace-code-early code)
    (cond
      [(and-not-as-dirty
        (or-assume-continuation
         (& (code-type code) (<< code-flag-continuation code-flags-offset))))
       ;; continuation
       (space (cond
                [(and-counts (is_counting_root si _)) space-count-pure]
                [else space-continuation]))
       (vfasl-fail "closure")
       (size size-continuation)
       (mark one-bit counting-root)
       (case-mode
        [self-test]
        [else
         (copy-clos-code code)
         (copy-stack-length continuation-stack-length continuation-stack-clength)
         (copy continuation-stack-clength)
         (trace-nonself continuation-winders)
         (trace-nonself continuation-attachments)
         (cond
           [(== (continuation-stack-length _) scaled-shot-1-shot-flag)]
           [else
            (case-mode
             [sweep
              (when (OLDSPACE (continuation-stack _))
                (set! (continuation-stack _)
                      (copy_stack (continuation-stack _)
                                  (& (continuation-stack-length _))
                                  (continuation-stack-clength _))))]
             [else])
            (count countof-stack (continuation-stack-length _) 1 [sweep measure])
            (trace continuation-link)
            (trace-return continuation-return-address (continuation-return-address _))
            (case-mode
             [copy (copy continuation-stack)]
             [else
              (define stack : uptr (cast uptr (continuation-stack _)))
              (trace-stack stack
                           (+ stack (continuation-stack-clength _))
                           (cast uptr (continuation-return-address _)))])])])
       (count countof-continuation)]

      [else
       ;; closure (not a continuation)
       (space
        (cond
          [(and-counts (is_counting_root si _)) space-count-impure]
          [_backreferences?_
           space-closure]
          [else
           (cond
             [(& (code-type code) (<< code-flag-mutable-closure code-flags-offset))
              space-impure]
             [else
              space-pure])]))
       (vspace vspace_closure)
       (when-vfasl
        (when (& (code-type code) (<< code-flag-mutable-closure code-flags-offset))
          (vfasl-fail "mutable closure")))
       (define len : uptr (code-closure-length code))
       (size (size_closure len))
       (when-mark
        (case-space
         [space-pure
          (mark one-bit counting-root)
          (count countof-closure)]
         [else
          (mark counting-root)
          (count countof-closure)]))
       (when (or-not-as-dirty
              (& (code-type code) (<< code-flag-mutable-closure code-flags-offset)))
         (copy-clos-code code)
         (trace-ptrs closure-data len))
       (pad (when (== (& len 1) 0)
              (set! (closure-data _copy_ len) (FIX 0))))
       (count countof-closure)])]
   
   [symbol
    (space space-symbol)
    (vspace vspace_symbol)
    (size size-symbol)
    (mark one-bit)
    (trace/define symbol-value val :vfasl-as (FIX (vfasl_symbol_to_index vfi _)))
    (trace-symcode symbol-pvalue val)
    (trace-nonself/vfasl-as-nil symbol-plist)
    (trace-nonself symbol-name)
    (trace-nonself/vfasl-as-nil symbol-splist)
    (trace-nonself symbol-hash)
    (count countof-symbol)]
   
   [flonum
    (space space-data)
    (vspace vspace_data)
    (size size-flonum)
    (mark)
    (copy-flonum flonum-data)
    (count countof-flonum)
    (skip-forwarding)]
   
   [typed-object
    (case-typefield

     [record
      (trace-early-rtd record-type)
      ;; If the rtd is the only pointer and is immutable, put the record
      ;; into space-data. If the record contains only pointers, put it
      ;; into space-pure or space-impure. Otherwise, put it into
      ;; space-pure-typed-object or space-impure-record. We could put all
      ;; records into space-{pure,impure}-record or even into
      ;; space-impure-record, but by picking the target space more
      ;; carefully, we may reduce fragmentation and sweeping cost.
      (define rtd : ptr (record-type _))
      (space
       (cond
         [(and-counts (is_counting_root si _))
          space-count-impure]
         [(&& (== (record-type-pm rtd) (FIX 1))
              (== (record-type-mpm rtd) (FIX 0)))
          ;; No pointers except for type
          space-data]
         [(== (record-type-pm rtd) (FIX -1))
          ;; All pointers
          (cond
           [_backreferences?_
            (cond
              [(== (record-type-mpm rtd) (FIX 0))
               ;; All immutable
               space-pure-typed-object]
              [else
               space-impure-record])]
           [else
            (cond
              [(== (record-type-mpm rtd) (FIX 0))
               ;; All immutable
               space-pure]
              [else
               space-impure])])]
         [else
          ;; Mixture of pointers and non-pointers
          (cond
            [(== (record-type-mpm rtd) (FIX 0))
             ;; All immutable
             space-pure-typed-object]
            [else
             space-impure-record])]))
      (vspace (cond
                [(is_rtd rtd vfi) vspace_rtd]
                [(== (record-type-mpm rtd) (FIX 0)) vspace_pure_typed]
                [else vspace_impure_record]))
      (vfasl-check-parent-rtd rtd)
      (define len : uptr (UNFIX (record-type-size rtd)))
      (size (size_record_inst len))
      (mark counting-root)
      (trace-record rtd len)
      (vfasl-set-base-rtd)
      (pad (when (or-vfasl
                  (\|\| (== p_spc space-pure) (\|\| (== p_spc space-impure)
                                               (and-counts (== p_spc space-count-impure)))))
             (let* ([ua_size : uptr (unaligned_size_record_inst len)])
               (when (!= p_sz ua_size)
                 (set! (* (cast ptr* (+ (cast uptr (UNTYPE _copy_ type_typed_object)) ua_size)))
                       (FIX 0))))))
      (count-record rtd)]

     [vector
      ;; Assumes vector lengths look like fixnums;
      ;; if not, vectors will need their own space
      (space
       (cond
         [(& (cast uptr _tf_) vector_immutable_flag)
          (cond
           [_backreferences?_ space-pure-typed-object]
           [else space-pure])]
         [else
          (cond
           [_backreferences?_ space-impure-typed-object]
           [else space-impure])]))
      (vspace vspace_impure)
      (define len : uptr (Svector_length _))
      (size (size_vector len))
      (mark)
      (copy-type vector-type)
      (trace-ptrs vector-data len)
      (pad (when (== (& len 1) 0)
             (set! (vector-data _copy_ len) (FIX 0))))
      (count countof-vector)]

     [stencil-vector
      ;; Assumes stencil-vector masks look like fixnums;
      ;; if not, stencil vectors will need their own space
      (space
       (cond
        [_backreferences?_ space-impure-typed-object]
        [else space-impure]))
      (vspace vspace_impure)
      (define len : uptr (Sstencil_vector_length _))
      (size (size_stencil_vector len))
      (mark within-segment) ; see assertion
      (assert-stencil-vector-size)
      (copy-type stencil-vector-type)
      (trace-ptrs stencil-vector-data len)
      (pad (when (== (& len 1) 0)
             (set! (stencil-vector-data _copy_ len) (FIX 0))))
      (count countof-stencil-vector)]

     [string
      (space space-data)
      (vspace vspace_data)
      (define sz : uptr (size_string (Sstring_length _)))
      (size (just sz))
      (mark)
      (copy-bytes string-type sz)
      (count countof-string)]

     [fxvector
      (space space-data)
      (vspace vspace_data)
      (define sz : uptr (size_fxvector (Sfxvector_length _)))
      (size (just sz))
      (mark)
      (copy-bytes fxvector-type sz)
      (count countof-fxvector)]

     [bytevector
      (space space-data)
      (vspace vspace_data)
      (define sz : uptr (size_bytevector (Sbytevector_length _)))
      (size (just sz))
      (mark)
      (copy-bytes bytevector-type sz)
      (count countof-bytevector)]

     [tlc
      (space
       (cond
        [_backreferences?_ space-impure-typed-object]
        [else space-impure]))
      (vfasl-fail "tlc")
      (size size-tlc)
      (mark)
      (copy-type tlc-type)
      (trace-nonself tlc-ht)
      (as-mark-end
       (trace-tlc tlc-next tlc-keyval)
       (count countof-tlc))]

     [box
      (space
       (cond
         [(== (box-type _) type-immutable-box)
          (cond
           [_backreferences?_ space-pure-typed-object]
           [else space-pure])]
         [else
          (cond
            [_backreferences?_ space-impure-typed-object]
            [else space-impure])]))
      (vspace vspace_impure)
      (size size-box)
      (mark)
      (copy-type box-type)
      (trace box-ref)
      (count countof-box)]

     [ratnum
      (space space-data)
      (vspace vspace_impure) ; would be better if we had pure, but these are rare
      (size size-ratnum)
      (copy-type ratnum-type)
      (trace-immutable-now ratnum-numerator)
      (trace-immutable-now ratnum-denominator)
      (mark)
      (vfasl-pad-word)
      (count countof-ratnum)]

     [exactnum
      (space space-data)
      (vspace vspace_impure) ; same rationale as ratnum
      (size size-exactnum)
      (copy-type exactnum-type)
      (trace-immutable-now exactnum-real)
      (trace-immutable-now exactnum-imag)
      (mark)
      (vfasl-pad-word)
      (count countof-exactnum)]

     [inexactnum
      (space space-data)
      (vspace vspace_data)
      (size size-inexactnum)
      (mark)
      (copy-type inexactnum-type)
      (copy-flonum* inexactnum-real)
      (copy-flonum* inexactnum-imag)
      (count countof-inexactnum)]

     [bignum
      (space space-data)
      (vspace vspace_data)
      (define sz : uptr (size_bignum (BIGLEN _)))
      (size (just sz))
      (mark)
      (copy-bytes bignum-type sz)
      (count countof-bignum)]

     [port
      (space space-port)
      (vfasl-fail "port")
      (size size-port)
      (mark one-bit)
      (copy-type port-type)
      (trace-nonself port-handler)
      (copy port-ocount)
      (copy port-icount)
      (trace-buffer PORT_FLAG_OUTPUT port-obuffer port-olast)
      (trace-buffer PORT_FLAG_INPUT port-ibuffer port-ilast)
      (trace port-info)
      (trace-nonself port-name)
      (count countof-port)]

     [code
      (space space-code)
      (vspace vspace_code)
      (define len : uptr (code-length _)) ; in bytes
      (size (size_code len))
      (mark one-bit)
      (when (and-not-as-dirty 1)
       (copy-type code-type)
       (copy code-length)
       (copy code-reloc)
       (trace-nonself code-name)
       (trace-nonself code-arity-mask)
       (copy code-closure-length)
       (trace-nonself code-info)
       (trace-nonself code-pinfo*)
       (trace-code len))
      (count countof-code)]

     [thread
      (space (cond
               [(and-counts (is_counting_root si _)) space-count-pure]
               [else space-pure-typed-object]))
      (vfasl-fail "thread")
      (size size-thread)
      (mark one-bit)
      (case-mode
       [self-test]
       [else
        (copy-type thread-type)
        (when (and-not-as-dirty 1)
          (trace-tc thread-tc))])
      (count countof-thread)]

     [rtd-counts
      (space space-data)
      (vfasl-as-false "rtd-counts") ; prune counts, since GC will recreate as needed
      (size size-rtd-counts)
      (mark)
      (copy-bytes rtd-counts-type size_rtd_counts)
      (count countof-rtd-counts)]

     [phantom
      (space space-data)
      (vfasl-fail "phantom")
      (size size-phantom)
      (mark)
      (copy-type phantom-type)
      (copy phantom-length)
      (case-mode
       [(copy mark)
        (as-mark-end
         (count countof-phantom)
         ;; Separate from `count`, because we want to track sizes even
         ;; if counting is not enabled:
         (set! (array-ref (array-ref S_G.bytesof _tg_) countof-phantom)
               +=
               (phantom-length _)))]
       [measure (set! measure_total += (phantom-length _))]
       [else])])]))

(define-trace-macro (trace-nonself field)
  (case-mode
   [self-test]
   [else
    (trace field)]))

(define-trace-macro (trace-nonself/vfasl-as-nil field)
  (case-mode
   [vfasl-copy
    (set! (field _copy_) Snil)]
   [else
    (trace-nonself field)]))

(define-trace-macro (try-double-pair do-car pair-car
                                     do-cdr pair-cdr
                                     count-pair)
  (case-mode
   [copy
    ;; Try to copy two pairs at a time
    (define cdr_p : ptr (Scdr _))
    (define qsi : seginfo* NULL)
    (cond
      [(&& (!= cdr_p _)
           (&& (== (TYPEBITS cdr_p) type_pair)
               (&& (!= (set! qsi (MaybeSegInfo (ptr_get_segment cdr_p))) NULL)
                   (&& (-> qsi old_space)
                       (&& (== (-> qsi space) (-> si space))
                           (&& (!= (FWDMARKER cdr_p) forward_marker)
                               (&& (! (-> qsi use_marks))
                                   ;; Checking `marked_mask`, too, in
                                   ;; case the pair is locked
                                   (! (-> qsi marked_mask)))))))))
       (check_triggers qsi)
       (size size-pair 2)
       (define new_cdr_p : ptr (cast ptr (+ (cast uptr _copy_) size_pair)))
       (set! (pair-car _copy_) (pair-car _))
       (set! (pair-cdr _copy_) new_cdr_p)
       (set! (pair-car new_cdr_p) (pair-car cdr_p))
       (set! (pair-cdr new_cdr_p) (pair-cdr cdr_p))
       (set! (FWDMARKER cdr_p) forward_marker)
       (set! (FWDADDRESS cdr_p) new_cdr_p)
       (case-flag maybe-backreferences?
        [on (ADD_BACKREFERENCE_FROM new_cdr_p new_p)]
        [off])
       (count count-pair size-pair 2)]
      [else
       (size size-pair) 
       (do-car pair-car)
       (do-cdr pair-cdr)
       (count count-pair)])]
   [else
    (size size-pair)
    (mark)
    (assert (= (constant size-pair) (constant byte-alignment)))
    (do-car pair-car)
    (do-cdr pair-cdr)
    (count count-pair)]))

(define-trace-macro (add-ephemeron-to-pending)
  (case-mode
   [(sweep mark)
    (add_ephemeron_to_pending _)]
   [measure
    (add_ephemeron_to_pending_measure _)]
   [else]))

(define-trace-macro (assert-ephemeron-size-ok)
  ;; needed for dirty sweep strategy:
  (assert (zero? (modulo (constant bytes-per-card) (constant size-ephemeron)))))

(define-trace-macro (assert-stencil-vector-size)
  ;; needed for within-mark-byte
  (assert (< (+ (* (constant stencil-vector-mask-bits) (constant ptr-bytes))
                (constant header-size-stencil-vector)
                (constant byte-alignment))
             (constant bytes-per-segment))))

(define-trace-macro (trace-immutable-now ref)
  (when (and-not-as-dirty 1)
    (trace-now ref)))

(define-trace-macro (trace-code-early code)
  (unless-code-relocated
   (case-mode
    [(vfasl-sweep)
     ;; Special relocation handling for code in a closure:
     (set! code (vfasl_relocate_code vfi code))]
    [else
     (trace-early (just code))])))

(define-trace-macro (copy-clos-code code)
  (case-mode
   [(copy vfasl-copy)
    (SETCLOSCODE _copy_ code)]
   [(sweep)
    (unless-code-relocated
     (SETCLOSCODE _copy_ code))]
   [(vfasl-sweep)
    ;; Make the code pointer relative to the base address.
    ;; It's turned back absolute when loading from vfasl
    (define rel_code : ptr (cast ptr (ptr_diff code (-> vfi base_addr))))
    (SETCLOSCODE p rel_code)]
   [else]))

(define-trace-macro (copy-stack-length continuation-stack-length continuation-stack-clength)
  (case-mode
   [copy
    ;; Don't promote general one-shots, but promote opportunistic one-shots
    (cond
      [(== (continuation-stack-length _) opportunistic-1-shot-flag)
       (set! (continuation-stack-length _copy_) (continuation-stack-clength _))
       ;; May need to recur at end to promote link:
       (set! conts_to_promote (S_cons_in space_new 0 new_p conts_to_promote))]
      [else
       (copy continuation-stack-length)])]
   [else
    (copy continuation-stack-length)]))

(define-trace-macro (trace/define ref val :vfasl-as vfasl-val)
  (case-mode
   [(copy measure)
    (trace ref)]
   [sweep
    (define val : ptr (ref _))
    (trace (just val))  
    (set! (ref _) val)]
   [vfasl-copy
    (set! (ref _copy_) vfasl-val)]
   [else]))

(define-trace-macro (trace-symcode symbol-pvalue val)
  (case-mode
   [sweep
    (define code : ptr (cond
                         [(Sprocedurep val) (CLOSCODE val)]
                         [else (SYMCODE _)]))
    (trace (just code))
    (INITSYMCODE _ code)]
   [measure]
   [vfasl-copy
    (set! (symbol-pvalue _copy_) Snil)]
   [else
    (copy symbol-pvalue)]))

(define-trace-macro (trace-tlc tlc-next tlc-keyval)
  (case-mode
   [(copy mark)
    (define next : ptr (tlc-next _))
    (define keyval : ptr (tlc-keyval _))
    (case-mode
     [copy
      (set! (tlc-next _copy_) next)
      (set! (tlc-keyval _copy_) keyval)]
     [else])
    ;; If next isn't false and keyval is old, add tlc to a list of tlcs
    ;; to process later. Determining if keyval is old is a (conservative)
    ;; approximation to determining if key is old. We can't easily
    ;; determine if key is old, since keyval might or might not have been
    ;; swept already. NB: assuming keyvals are always pairs.
    (when (&& (!= next Sfalse) (OLDSPACE keyval))
      (set! tlcs_to_rehash (S_cons_in space_new 0 _copy_ tlcs_to_rehash)))]
   [else
    (trace-nonself tlc-keyval)
    (trace-nonself tlc-next)]))

(define-trace-macro (trace-record trd len)
  (case-mode
   [(copy vfasl-copy)
    (copy-bytes record-data (- len ptr_bytes))]
   [else
    ;; record-type descriptor was forwarded already
    (let* ([num : ptr (case-flag as-dirty?
                       [on (record-type-mpm rtd)]
                       [off (record-type-pm rtd)])]
           [pp : ptr* (& (record-data _ 0))])
      ;; Process cells for which bit in pm is set, and quit when pm == 0
      (cond
        [(Sfixnump num)
         ;; Ignore bit for already forwarded rtd
         (let* ([mask : uptr (>> (cast uptr (UNFIX num)) 1)])
           (cond
             [(case-flag as-dirty?
               [on 0]
               [off (== mask (>> (cast uptr -1) 1))])
              (let* ([ppend : ptr* (- (cast ptr* (+ (cast uptr pp) len)) 1)])
                (while
                 :? (< pp ppend)
                 (trace (* pp))
                 (set! pp += 1)))]
             [else
              (while
               :? (!= mask 0)
               (when (& mask 1)
                 (trace (* pp)))
               (set! mask >>= 1)
               (set! pp += 1))]))]
        [else
         (case-flag as-dirty?
          [on]
          [off
           (case-mode
            [(sweep self-test)
             ;; Bignum pointer mask may need forwarding
             (trace (record-type-pm rtd))
             (set! num (record-type-pm rtd))]
            [else])])
         (let* ([index : iptr (- (BIGLEN num) 1)]
                ;; Ignore bit for already forwarded rtd
                [mask : bigit (>> (bignum-data num index) 1)]
                [bits : INT (- bigit_bits 1)])
           (while
            :? 1
            (do-while
             (when (& mask 1)
               (trace (* pp)))
             (set! mask >>= 1)
             (set! pp += 1)
             (set! bits -= 1)
             ;; while:
             :? (> bits 0))
            (when (== index 0) (break))
            (set! index -= 1)
            (set! mask (bignum-data num index))
            (set! bits bigit_bits)))]))]))

(define-trace-macro (vfasl-check-parent-rtd rtd)
  (case-mode
   [(vfasl-copy)
    (when (is_rtd rtd vfi)
      (when (!= _ S_G.base_rtd)
        ;; Make sure rtd's type is registered firs, but
        ;; discard the relocated pointer (leaving to sweep)
        (cast void (vfasl_relocate_help vfi rtd)))
      ;; Need parent before child
      (vfasl_relocate_parents vfi (record-type-parent _)))]
   [(vfasl-sweep)
    ;; Don't need to save fields of base-rtd
    (when (== _ (-> vfi base_rtd))
      (let* ([pp : ptr* (& (record-data _ 0))]
             [ppend : ptr* (- (cast ptr* (+ (cast uptr pp) (UNFIX (record-type-size rtd)))) 1)])
        (while
         :? (< pp ppend)
         (set! (* pp) Snil)
         (set! pp += 1))
        (return (size_record_inst (UNFIX (record-type-size rtd))))))
    ;; Relocation of rtd fields was deferred
    (vfasl_relocate vfi (& (record-type _)))]
   [else]))

(define-trace-macro (vfasl-set-base-rtd)
  (case-mode
   [(vfasl-copy)
    (when (== _ S_G.base_rtd)
      (set! (-> vfi base_rtd) _copy_))]
   [else]))

(define-trace-macro (count-record rtd)
  (case-mode
   [(copy mark)
    (as-mark-end
     (case-flag counts?
      [on
       (when S_G.enable_object_counts
         (let* ([c_rtd : ptr (cond
                               [(== _tf_ _) _copy_]
                               [else rtd])]
                [counts : ptr (record-type-counts c_rtd)])
           (cond
             [(== counts Sfalse)
              (let* ([grtd : IGEN (GENERATION c_rtd)])
                (set! (array-ref (array-ref S_G.countof grtd) countof_rtd_counts) += 1)
                ;; Allocate counts struct in same generation as rtd. Initialize timestamp & counts.
                (find_room space_data grtd type_typed_object size_rtd_counts counts)
                (set! (rtd-counts-type counts) type_rtd_counts)
                (set! (rtd-counts-timestamp counts) (array-ref S_G.gctimestamp 0))
                (let* ([g : IGEN 0])
                  (while
                   :? (<= g static_generation)
                   (set! (rtd-counts-data counts g) 0)
                   (set! g += 1)))
                (set! (record-type-counts c_rtd) counts)
                (set! (array-ref S_G.rtds_with_counts grtd)
                      ;; For max_copied_generation, the list will get copied again in `rtds_with_counts` fixup;
                      ;; meanwhile, allocating in `space_impure` would copy and sweep old list entries causing
                      ;; otherwise inaccessible rtds to be retained
                      (S_cons_in (cond [(<= grtd max_copied_generation) space_new] [else space_impure])
                                 (cond [(<= grtd max_copied_generation) 0] [else grtd])
                                 c_rtd
                                 (array-ref S_G.rtds_with_counts grtd)))
                (set! (array-ref (array-ref S_G.countof grtd) countof_pair) += 1))]
             [else
              (trace-early (just counts))
              (set! (record-type-counts c_rtd) counts)
              (when (!= (rtd-counts-timestamp counts) (array-ref S_G.gctimestamp 0))
                (S_fixup_counts counts))])
           (set! (rtd-counts-data counts _tg_) (+ (rtd-counts-data counts _tg_) 1))))
       ;; Copies size that we may have already gathered, but needed for counting from roots:
       (case-mode
        [(copy)
         (when (== p_spc space-count-impure) (set! count_root_bytes += p_sz))]
        [else])
       (count countof-record)]
      [off]))]
   [else]))

(define-trace-macro (trace-buffer flag port-buffer port-last)
  (case-mode
   [(copy measure)
    (copy port-last)
    (copy port-buffer)]
   [sweep
    (when (& (cast uptr _tf_) flag)
      (define n : iptr (- (cast iptr (port-last _))
                          (cast iptr (port-buffer _))))
      (trace port-buffer)
      (set! (port-last _) (cast ptr (+ (cast iptr (port-buffer _)) n))))]
   [else
    (trace-nonself port-buffer)]))

(define-trace-macro (trace-tc offset)
  (case-mode
   [copy
    (copy offset)]
   [else
    (define tc : ptr (cast ptr (offset _)))
    (when (!= tc (cast ptr 0))
      (case-mode
       [sweep
        (let* ([old_stack : ptr (tc-scheme-stack tc)])
          (when (OLDSPACE old_stack)
            (let* ([clength : iptr (- (cast uptr (SFP tc)) (cast uptr old_stack))])
              ;; Include SFP[0], which contains the return address
              (set! (tc-scheme-stack tc) (copy_stack old_stack
                                                     (& (tc-scheme-stack-size tc))
                                                     (+ clength (sizeof ptr))))
              (count countof-stack (tc-scheme-stack-size tc) 1 sweep)
              (set! (tc-sfp tc) (cast ptr (+ (cast uptr (tc-scheme-stack tc)) clength)))
              (set! (tc-esp tc) (cast ptr (- (+ (cast uptr (tc-scheme-stack tc))
                                                (tc-scheme-stack-size tc))
                                             stack_slop))))))]
       [measure
        (measure_add_stack_size (tc-scheme-stack tc) (tc-scheme-stack-size tc))]
       [else])
      (set! (tc-stack-cache tc) Snil)
      (trace (tc-cchain tc))
      (trace (tc-stack-link tc))
      (trace (tc-winders tc))
      (trace (tc-attachments tc))
      (case-mode
       [sweep
        (set! (tc-cached-frame tc) Sfalse)]
       [else])
      (trace-return NO-COPY-MODE (FRAME tc 0))
      (trace-stack (cast uptr (tc-scheme-stack tc))
                   (cast uptr (SFP tc))
                   (cast uptr (FRAME tc 0)))
      (case-mode
       [(sweep)
        (set! (tc-U tc) 0)
        (set! (tc-V tc) 0)
        (set! (tc-W tc) 0)
        (set! (tc-X tc) 0)
        (set! (tc-Y tc) 0)]
       [else])
      (trace (tc-threadno tc))
      (trace (tc-current-input tc))
      (trace (tc-current-output tc))
      (trace (tc-current-error tc))
      (trace (tc-sfd tc))
      (trace (tc-current-mso tc))
      (trace (tc-target-machine tc))
      (trace (tc-fxlength-bv tc))
      (trace (tc-fxfirst-bit-set-bv tc))
      (trace (tc-null-immutable-vector tc))
      (trace (tc-null-immutable-fxvector tc))
      (trace (tc-null-immutable-bytevector tc))
      (trace (tc-null-immutable-string tc))
      (trace (tc-compile-profile tc))
      (trace (tc-subset-mode tc))
      (trace (tc-default-record-equal-procedure tc))
      (trace (tc-default-record-hash-procedure tc))
      (trace (tc-compress-format tc))
      (trace (tc-compress-level tc))
      (trace (tc-parameters tc))
      (let* ([i : INT 0])
        (while
         :? (< i virtual_register_count)
         (trace (tc-virtual-registers tc i))
         (set! i += 1))))]))

(define-trace-macro (trace-stack base-expr fp-expr ret-expr)
  (define base : uptr base-expr)
  (define fp : uptr fp-expr)
  (define ret : uptr ret-expr)

  (while
   :? (!= fp base)
   (when (< fp base)
     (S_error_abort "sweep_stack(gc): malformed stack"))
   (set! fp (- fp (ENTRYFRAMESIZE ret)))
   (let* ([pp : ptr* (cast ptr* fp)]
          [oldret : iptr ret])
     (set! ret (cast iptr (* pp)))
     (trace-return NO-COPY-MODE (* pp))
     (let* ([num : ptr (ENTRYLIVEMASK oldret)])
       (cond
         [(Sfixnump num)
          (let* ([mask : uptr (UNFIX num)])
            (while
             :? (!= mask 0)
             (set! pp += 1)
             (when (& mask #x0001)
               (trace (* pp)))
             (set! mask >>= 1)))]
         [else
          (trace (* (ENTRYNONCOMPACTLIVEMASKADDR oldret)))

          (let* ([num : ptr (ENTRYLIVEMASK oldret)]
                 [index : iptr (BIGLEN num)])
            (while
             :? (!= index 0)
             (set! index -= 1)
             (let* ([bits : INT bigit_bits]
                    [mask : bigit (bignum-data num index)])
               (while
                :? (> bits 0)
                (set! bits -= 1)
                (set! pp += 1)
                (when (& mask 1) (trace (* pp)))
                (set! mask >>= 1)))))])))))

(define-trace-macro (trace-return copy-field field)
  (case-mode
   [copy
    (copy copy-field)]
   [else
    (define xcp : ptr field)
    (trace-return-code field xcp)]))

(define-trace-macro (trace-return-code field xcp)
  (define co : iptr (+ (ENTRYOFFSET xcp) (- (cast uptr xcp) (cast uptr (ENTRYOFFSETADDR xcp)))))
  (define c_p : ptr (cast ptr (- (cast uptr xcp) co)))
  (case-mode
   [sweep
    (define x_si : seginfo* (SegInfo (ptr_get_segment c_p)))
    (when (-> x_si old_space)
      (relocate_code c_p x_si)
      (set! field (cast ptr (+ (cast uptr c_p) co))))]
   [else
    (trace (just c_p))]))

(define-trace-macro (trace-code len)
  (case-mode
   [(copy vfasl-copy)
    (copy-bytes code-data len)]
   [else
    (define t : ptr (code-reloc _))
    (case-mode
     [(sweep vfasl-sweep)
      (define m : iptr (reloc-table-size t))
      (define oldco : ptr (reloc-table-code t))]
     [else
      (define m : iptr (cond
                         [t (reloc-table-size t)]
                         [else 0]))
      (define oldco : ptr (cond
                            [t (reloc-table-code t)]
                            [else 0]))])
    (case-mode
     [vfasl-sweep
      (let* ([r_sz : uptr (size_reloc_table m)]
             [new_t : ptr (vfasl_find_room vfi vspace_reloc typemod r_sz)])
        (memcpy_aligned new_t t r_sz)
        (set! t new_t))]
     [else])
    (define a : iptr 0)
    (define n : iptr 0)
    (while
     :? (< n m)
     (let* ([entry : uptr (reloc-table-data t n)]
            [item_off : uptr 0]
            [code_off : uptr 0])
       (set! n (+ n 1))
       (cond
         [(RELOC_EXTENDED_FORMAT entry)
          (set! item_off (reloc-table-data t n))
          (set! n (+ n 1))
          (set! code_off (reloc-table-data t n))
          (set! n (+ n 1))]
         [else
          (set! item_off (RELOC_ITEM_OFFSET entry))
          (set! code_off (RELOC_CODE_OFFSET entry))])
       (set! a (+ a code_off))
       (let* ([obj : ptr (S_get_code_obj (RELOC_TYPE entry) oldco a item_off)])
         (case-mode
          [vfasl-sweep
           (set! obj (vfasl_encode_relocation vfi obj))]
          [else
           (trace (just obj))])
         (case-mode
          [sweep
           (S_set_code_obj "gc" (RELOC_TYPE entry) _ a obj item_off)]
          [vfasl-sweep
           (S_set_code_obj "vfasl" (abs_reloc_variant (RELOC_TYPE entry)) _ a obj item_off)]
          [else]))))

    (case-mode
     [sweep
      (cond
        [(&& (== target_generation static_generation)
             (&& (! S_G.retain_static_relocation)
                 (== 0 (& (code-type _) (<< code_flag_template code_flags_offset)))))
         (set! (code-reloc _) (cast ptr 0))]
        [else
         (let* ([t_si : seginfo* (SegInfo (ptr_get_segment t))])
           (when (-> t_si old_space)
             (set! n (size_reloc_table (reloc-table-size t)))
             (count countof-relocation-table (just n) 1 sweep)
             (cond
               [(-> t_si use_marks)
                ;; Assert: (! (marked t_si t))
                (mark_typemod_data_object t n t_si)]
               [else
                (let* ([oldt : ptr t])
                  (find_room space_data target_generation typemod n t)
                  (memcpy_aligned t oldt n))])))
         (set! (reloc-table-code t) _)
         (set! (code-reloc _) t)])
      (S_record_code_mod tc_in (cast uptr (& (code-data _ 0))) (cast uptr (code-length _)))]
     [vfasl-sweep
      ;; no vfasl_register_pointer, since relink_code can handle it
      (set! (reloc-table-code t) (cast ptr (ptr_diff _ (-> vfi base_addr))))
      (set! (code-reloc _) (cast ptr (ptr_diff t (-> vfi base_addr))))]
     [else])]))

(define-trace-macro (unless-code-relocated stmt)
  (case-flag code-relocated?
   [on]
   [off
    (case-flag as-dirty?
     [on]
     [off stmt])]))

(define-trace-macro (or-assume-continuation e)
  (case-flag assume-continuation?
   [on 1]
   [off e]))

(define-trace-macro (and-counts e)
  (case-flag counts?
   [on e]
   [off 0]))

(define-trace-macro (and-not-as-dirty e)
  (case-flag as-dirty?
   [on 0]
   [off e]))

(define-trace-macro (or-not-as-dirty e)
  (case-flag as-dirty?
   [on e]
   [off 1]))

(define-trace-macro (or-vfasl e)
  (case-mode
   [vfasl-copy 1]
   [else e]))

(define-trace-macro (when-vfasl e)
  (case-mode
   [(vfasl-copy vfasl-sweep) e]
   [else]))

(define-trace-macro (when-mark e)
  (case-mode
   [(mark) e]
   [else]))

(define-trace-macro (pad e)
  (case-mode
   [(copy vfasl-copy) e]
   [else]))

(define-trace-macro (vfasl-pad-word)
  (case-mode
   [(vfasl-copy)
    (set! (array-ref (cast void** (UNTYPE _copy_ type_typed_object)) 3)
          (cast ptr 0))]
   [else]))

(define-trace-macro (vfasl-fail what)
  (case-mode
   [(vfasl-copy vfasl-sweep)
    (vfasl_fail vfi what)
    (case-mode
     [vfasl-copy (return (cast ptr 0))]
     [vfasl-sweep (return 0)])
    (vspace #f)]
   [else]))

(define-trace-macro (vfasl-as-false what)
  (case-mode
   [(vfasl-copy)
    (return Sfalse)
    (vspace #f)]
   [(vfasl-sweep)
    (vfasl-fail what)
    (vspace #f)]
   [else]))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parenthe-C compiler
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Every compiler needs its own little implementation of `match`, right?
;; Just pairs and literals, no ellipses.
(define-syntax (match stx)
  (syntax-case stx (else)
    [(_ expr [pattern rhs ...] ... [else else-rhs ...])
     #'(let ([v expr]) (matching v [pattern rhs ...] ... [else else-rhs ...]))]
    [(_ expr [pattern rhs ...] ...)
     #'(let ([v expr]) (match v [pattern rhs ...] ... [else (error 'match "no matching clause: ~s" v)]))]))

(define-syntax (matching stx)
  (syntax-case stx ()
    [(_ v [else rhs ...])
     #'(let () rhs ...)]
    [(_ v [pattern rhs ...] more ...)
     (letrec ([gen-match (lambda (pat quoted?)
                           (cond
                             [(identifier? pat)
                              (if quoted?
                                  #`(eq? v '#,pat)
                                  #t)]
                             [else
                              (syntax-case pat (quasiquote unquote)
                                [(quasiquote p)
                                 (if quoted?
                                     (error 'match "bad quasiquote")
                                     (gen-match #'p #t))]
                                [(unquote p)
                                 (if quoted?
                                     (gen-match #'p #f)
                                     (error 'match "bad unquote"))]
                                [(a . b)
                                 #`(and (pair? v)
                                        (let ([v (car v)])
                                          #,(gen-match #'a quoted?))
                                        (let ([v (cdr v)])
                                          #,(gen-match #'b quoted?)))]
                                [other
                                 #'(equal? v 'other)])]))]
              [get-binds (lambda (pat quoted?)
                           (cond
                             [(identifier? pat)
                              (if quoted?
                                  '()
                                  (list pat))]
                             [else
                              (syntax-case pat (quasiquote unquote)
                                [(quasiquote p)
                                 (get-binds #'p #t)]
                                [(unquote p)
                                 (get-binds #'p #f)]
                                [(a . b)
                                 (append (get-binds #'a quoted?)
                                         (get-binds #'b quoted?))]
                                [other '()])]))]
              [get-vals (lambda (pat quoted?)
                          (cond
                            [(identifier? pat)
                             (if quoted?
                                 #''()
                                 #'(list v))]
                            [else
                             (syntax-case pat (quasiquote unquote)
                               [(quasiquote p)
                                (get-vals #'p #t)]
                               [(unquote p)
                                (get-vals #'p #f)]
                               [(a . b)
                                #`(append (let ([v (car v)])
                                            #,(get-vals #'a quoted?))
                                          (let ([v (cdr v)])
                                            #,(get-vals #'b quoted?)))]
                               [other #''()])]))])
       (syntax-case #'pattern (quasiquote)
         [(quasiquote p)
          #`(if #,(gen-match #'pattern #f)
                (let-values ([#,(get-binds #'pattern #f)
                              (apply values #,(get-vals #'pattern #f))])
                  rhs ...)
                (matching v more ...))]
         [_
          (error 'match "bad pattern ~s" #'pattern)]))]))

(let ()

  (define preserve-flonum-eq? #t)
  
  ;; A config is an association list. Mostly, it determines the
  ;; generation mode, but it is also used to some degree as an
  ;; environment-like map to communicate information from one
  ;; statement to later statements.
  ;;
  ;; Some keys:
  ;;   - 'mode [required]
  ;;   - 'maybe-backreferences?
  ;;   - 'known-space [to prune generated cases]
  ;;   - 'known-types [to prune generated cases]

  (define lookup
    (case-lambda
     [(key config default)
      (let ([a (assq key config)])
        (if a
            (cadr a)
            default))]
     [(key config)
      (let ([a (assq key config)])
        (if a
            (cadr a)
            (error 'lookup "not found: ~s" key)))]))

  ;; A sqeuence wraps a list of string and other sequences with
  ;; formatting information
  (define-record-type seq
    (fields l))
  (define-record-type block-seq
    (fields l))
  (define-record-type indent-seq
    (fields pre mid post))

  ;; More convenient constructors for sequences:
  (define (code . l) (make-seq l))
  (define (code-block . l) (make-block-seq l))
  (define (code-indent pre mid post) (make-indent-seq pre mid post))

  ;; Main C-generation entry point:
  (define (generate name config)
    (define base-types (prune trace-base-types config))
    (define object-types (prune trace-object-types config))
    (define mode (lookup 'mode config))
    (code
     (format "static ~a ~a(~aptr p~a)"
             (case (lookup 'mode config)
               [(copy vfasl-copy) "ptr"]
               [(size vfasl-sweep) "uptr"]
               [(self-test) "IBOOL"]
               [(sweep) (if (lookup 'as-dirty? config #f)
                            "IGEN"
                            "void")]
               [(mark) "void"]
               [else "void"])
             name
             (case (lookup 'mode config)
               [(sweep)
                (if (and (type-included? 'code config)
                         (not (lookup 'as-dirty? config #f)))
                    "ptr tc_in, "
                    "")]
               [(vfasl-copy vfasl-sweep)
                "vfasl_info *vfi, "]
               [else ""])
             (case (lookup 'mode config)
               [(copy mark vfasl-copy) ", seginfo *si"]
               [(sweep)
                (if (lookup 'as-dirty? config #f)
                    ", IGEN tg, IGEN youngest"
                    "")]
               [else ""]))
     (let ([body
            (lambda ()
              (let ([config (cons (list 'used (make-eq-hashtable)) config)])
                (cond
                  [(null? base-types)
                   (cond
                     [(null? object-types)
                      (error 'generate "no relevant types")]
                     [(null? (cdr object-types))
                      (code-block (statements (cdar object-types)
                                              (cons `(type ,(caar object-types)) config)))]
                     [else
                      (generate-typed-object-dispatch object-types (cons '(basetype typed-object) config))])]
                  [else
                   (cond
                     [(null? object-types)
                      (generate-type-dispatch base-types config)]
                     [else
                      (generate-type-dispatch 
                       (cons (cons 'typed-object
                                   (generate-typed-object-dispatch object-types (cons '(basetype typed-object)
                                                                                      config)))
                             base-types)
                       config)])])))])
       (case (lookup 'mode config)
         [(copy)
          (code-block
           "change = 1;"
           "check_triggers(si);"
           (code-block
            "ptr new_p;"
            "IGEN tg = target_generation;"
            (body)
            "FWDMARKER(p) = forward_marker;"
            "FWDADDRESS(p) = new_p;"
            (and (lookup 'maybe-backreferences? config #f)
                 "ADD_BACKREFERENCE(p)")
            "return new_p;"))]
         [(mark)
          (code-block
           "change = 1;"
           "check_triggers(si);"
           (ensure-segment-mark-mask "si" "" '())
           (body)
           "ADD_BACKREFERENCE(p)")]
         [(sweep)
          (code-block
           (and (lookup 'maybe-backreferences? config #f)
                "PUSH_BACKREFERENCE(p)")
           (body)
           (and (lookup 'maybe-backreferences? config #f)
                "POP_BACKREFERENCE()")
           (and (lookup 'as-dirty? config #f)
                "return youngest;"))]
         [(measure)
          (body)]
         [(self-test)
          (code-block
           (body)
           "return 0;")]
         [(vfasl-copy)
          (code-block
           "ptr new_p;"
           (body)
           "vfasl_register_forward(vfi, p, new_p);"
           "return new_p;")]
         [(vfasl-sweep)
          (code-block
           "uptr result_sz;"
           (body)
           "return result_sz;")]
         [else
          (body)]))))

  (define (generate-type-dispatch l config)
    (let ([multi? (and (pair? l) (pair? (cdr l)))])
      (code-block
       (and multi? "ITYPE t = TYPEBITS(p);")
       (let loop ([l l] [else? #f])
         (cond
           [(null? l)
            (and multi?
                 (code "else"
                       (code-block
                        (format "S_error_abort(\"~a: illegal type\");" (lookup 'mode config)))))]
           [else
            (code
             (and multi?
                  (format "~aif (t == ~a)" (if else? "else " "") (as-c 'type (caar l))))
             (let ([c (cdar l)])
               (if (block-seq? c)
                   c
                   (code-block (statements c (cons (list 'basetype (caar l))
                                                           config)))))
             (loop (cdr l) #t))])))))

  (define (generate-typed-object-dispatch l config)
    (code-block
     "ptr tf = TYPEFIELD(p);"
     (let loop ([l l] [else? #f])
       (cond
         [(null? l)
          (code "else"
                (code-block
                 (format "S_error_abort(\"~a: illegal typed object type\");" (lookup 'mode config))))]
         [else
          (let* ([ty (caar l)]
                 [mask (lookup-constant (string->symbol (format "mask-~a" ty)))]
                 [type-constant? (eqv? mask (constant byte-constant-mask))])
            (code (format "~aif (~a)" (if else? "else " "")
                          (if type-constant?
                              (format "(iptr)tf == ~a" (as-c 'type ty))
                              (format "TYPEP(tf, ~a, ~a)" (as-c 'mask ty) (as-c 'type ty))))
                  (code-block (statements (cdar l) (cons* (list 'tf "tf")
                                                          (list 'type ty)
                                                          (if type-constant?
                                                              (cons `(type-constant ,(as-c 'type ty))
                                                                    config)
                                                              config))))
                  (loop (cdr l) #t)))]))))

  ;; list of S-expressions -> code sequence
  (define (statements l config)
    (cond
      [(null? l) (code)]
      [else
       (let ([a (car l)])
         (match a
           [`(case-mode . ,all-clauses)
            (let ([body (find-matching-mode (lookup 'mode config) all-clauses)])
              (statements (append body (cdr l)) config))]
           [`(case-space . ,all-clauses)
            (code
             (code-block
              (format "ISPC p_at_spc = ~a;"
                      (case (lookup 'mode config)
                        [(copy mark vfasl-copy) "si->space"]
                        [else "SPACE(p)"]))
              (let loop ([all-clauses all-clauses] [else? #f])
                (match all-clauses
                  [`([else . ,body])
                   (code
                    "else"
                    (code-block (statements body config)))]
                  [`([,spc . ,body] . ,rest)
                   (code
                    (format "~aif (p_at_spc == ~a)"
                            (if else? "else " "")
                            (as-c spc))
                    (code-block (statements body config))
                    (loop rest #t))])))
             (statements (cdr l) config))]
           [`(case-flag ,flag
                        [on . ,on]
                        [off . ,off])
            (let ([body (if (lookup flag config #f)
                            on
                            off)])
              (statements (append body (cdr l)) config))]
           [`(trace-early-rtd ,field)
            (code (case (and (not (lookup 'as-dirty? config #f))
                             (not (lookup 'rtd-relocated? config #f))
                             (lookup 'mode config))
                    [(copy sweep mark)
                     (code
                      "/* Relocate to make sure we aren't using an oldspace descriptor"
                      "   that has been overwritten by a forwarding marker, but don't loop"
                      "   on tag-reflexive base descriptor */"
                      (format "if (p != ~a)"
                              (lookup 'tf config (format "TYPEFIELD(p)")))
                      (code-block
                       (statements `((trace-early ,field)) config)))]
                    [(measure)
                     (statements `((trace-early ,field)) config)]
                    [else #f])
                  (statements (cdr l) (cons `(copy-extra-rtd ,field) config)))]
           [`(trace ,field)
            (code (trace-statement field config #f)
                  (statements (cdr l) config))]
           [`(trace-early ,field)
            (code (trace-statement field config #t)
                  (statements (cdr l) (if (symbol? field)
                                          (cons `(copy-extra ,field) config)
                                          config)))]
           [`(trace-now ,field)
            (code
             (case (lookup 'mode config)
               [(copy)
                (code-block
                 (format "ptr tmp_p = ~a;" (field-expression field config "p" #f))
                 (relocate-statement "tmp_p" config)
                 (format "~a = tmp_p;" (field-expression field config "new_p" #f)))]
               [(self-test) #f]
               [(measure vfasl-copy vfasl-sweep)
                (statements (list `(trace ,field)) config)]
               [(mark)
                (relocate-statement (field-expression field config "p" #t) config)]
               [else
                (trace-statement field config #f)])
             (statements (cdr l) config))]
           [`(copy ,field)
            (code (copy-statement field config)
                  (statements (cdr l) config))]
           [`(copy-flonum ,field)
            (cond
              [(and preserve-flonum-eq?
                    (eq? 'copy (lookup 'mode config)))
               (code (copy-statement field config)
                     "flonum_set_forwarded(p, si);"
                     "FLONUM_FWDADDRESS(p) = new_p;"
                     (statements (cdr l) config))]
              [else
               (statements (cons `(copy ,field) (cdr l)) config)])]
           [`(copy-flonum* ,field)
            (cond
              [preserve-flonum-eq?
               (case (lookup 'mode config)
                 [(copy)
                  (code (code-block
                         (format "ptr tmp_p = TYPE(&~a, type_flonum);" (field-expression field config "p" #t))
                         "if (flonum_is_forwarded_p(tmp_p, si))"
                         (format "  ~a = FLODAT(FLONUM_FWDADDRESS(tmp_p));"
                                 (field-expression field config "new_p" #f))
                         "else"
                         (format "  ~a = ~a;"
                                 (field-expression field config "new_p" #f)
                                 (field-expression field config "p" #f)))
                        (statements (cdr l) config))]
                 [(vfasl-copy)
                  (statements (cons `(copy ,field) (cdr l)) config)]
                 [else (statements (cdr l) config)])]
              [else
               (statements (cons `(copy ,field) (cdr l)) config)])]
           [`(copy-bytes ,offset ,len)
            (code (case (lookup 'mode config)
                    [(copy vfasl-copy)
                     (format "memcpy_aligned(&~a, &~a, ~a);"
                             (field-expression offset config "new_p" #t)
                             (field-expression offset config "p" #t)
                             (expression len config))]
                    [else #f])
                  (statements (cdr l) config))]
           [`(copy-type ,field)
            (case (lookup 'mode config)
              [(copy vfasl-copy)
               (code
                (format "~a = ~a;"
                        (field-expression field config "new_p" #f)
                        (or (lookup 'type-constant config #f)
                            "(uptr)tf"))
                (statements (cdr l) config))]
              [else
               (statements (cons `(copy ,field) (cdr l)) config)])]
           [`(trace-ptrs ,offset ,len)
            (case (lookup 'mode config)
              [(copy vfasl-copy)
               (statements (cons `(copy-bytes ,offset (* ptr_bytes ,len))
                                 (cdr l))
                           config)]
              [(sweep measure vfasl-sweep)
               (code
                (loop-over-pointers
                 (field-expression offset config "p" #t)
                 len
                 (trace-statement `(array-ref p_p idx) config #f)
                 config))]
              [(self-test)
               (code
                (loop-over-pointers (field-expression offset config "p" #t)
                                    len
                                    (code "if (p_p[idx] == p) return 1;")
                                    config)
                (statements (cdr l) config))]
              [else (statements (cdr l) config)])]
           [`(count ,counter)
            (code (count-statement counter #f 1 'copy config)
                  (statements (cdr l) config))]
           [`(count ,counter ,size)
            (statements (cons `(count ,counter ,size 1 copy) (cdr l)) config)]
           [`(count ,counter ,size ,scale)
            (statements (cons `(count ,counter ,size ,scale copy) (cdr l)) config)]
           [`(count ,counter ,size ,scale ,modes)
            (code (count-statement counter size scale modes
                                   (cons `(constant-size? ,(symbol? size))
                                         config))
                  (statements (cdr l) config))]
           [`(as-mark-end . ,stmts)
            (statements (append stmts (cdr l))
                        config)]
           [`(space ,s)
            (case (lookup 'mode config)
              [(copy)
               (code (code-indent "ISPC p_spc = "
                                  (expression s config #f #t)
                                  ";")
                     (statements (cdr l) (cons '(space-ready? #t) config)))]
              [(mark)
               (statements (cdr l) (if (symbol? s)
                                       (cons `(known-space ,s) config)
                                       config))]
              [else (statements (cdr l) config)])]
           [`(vspace ,s)
            (case (lookup 'mode config)
              [(vfasl-copy)
               (cond
                 [(not s) (code)]
                 [else
                  (code (code-indent "int p_vspc = "
                                     (expression s config #f #t)
                                     ";")
                        (statements (cdr l) (cons '(vspace-ready? #t) config)))])]
              [(vfasl-sweep)
               (cond
                 [(not s) (code)]
                 [else (statements (cdr l) config)])]
              [else (statements (cdr l) config)])]
           [`(size ,sz)
            (statements (cons `(size ,sz ,1) (cdr l)) config)]
           [`(size ,sz ,scale)
            (let* ([mode (lookup 'mode config)]
                   [mode (if (lookup 'return-size? config #f)
                             (case mode
                               [(sweep) 'sweep+size]
                               [else mode])
                             mode)]
                   [was-used? (let ([used? (hashtable-ref (lookup 'used config) 'p_sz #f)])
                                (hashtable-set! (lookup 'used config) 'p_sz #f)
                                used?)]
                   [config (if (and (symbol? sz)
                                    (eqv? scale 1))
                               (cons `(known-size ,sz) config)
                               config)]
                   [config (if (symbol? sz)
                               (cons '(constant-size? #t)
                                     config)
                               config)]
                   [rest
                    (case mode
                      [(copy vfasl-copy)
                       (case mode
                         [(copy) (unless (lookup 'space-ready? config #f)
                                   (error 'generate "size before space"))]
                         [(vfasl-copy) (unless (lookup 'vspace-ready? config #f)
                                         (error 'generate "size before vspace for ~a/~a"
                                                (lookup 'basetype config)
                                                (lookup 'type config #f)))])
                       (hashtable-set! (lookup 'used config) 'p_sz #t)
                       (code (format "~a, ~a, p_sz, new_p);"
                                     (case mode
                                       [(copy) "find_room(p_spc, tg"]
                                       [(vfasl-copy) "FIND_ROOM(vfi, p_vspc"])
                                     (as-c 'type (lookup 'basetype config)))
                             (statements (let ([extra (lookup 'copy-extra config #f)])
                                           (if extra
                                               (cons `(copy ,extra) (cdr l))
                                               (let* ([mode (lookup 'mode config)]
                                                      [extra (and (memq mode '(copy vfasl-copy))
                                                                  (lookup 'copy-extra-rtd config #f))])
                                                 (if extra
                                                     (cons `(set! (,extra _copy_)
                                                                  ,(case mode
                                                                     [(copy)
                                                                      `(cond
                                                                         [(== tf _) _copy_]
                                                                         [else rtd])]
                                                                     [else 'rtd]))
                                                           (cdr l))
                                                     (cdr l)))))
                                         (cons '(copy-ready? #t)
                                               config)))]
                      [(size)
                       (hashtable-set! (lookup 'used config) 'p_sz #t)
                       (code "return p_sz;")]
                      [(vfasl-sweep)
                       (hashtable-set! (lookup 'used config) 'p_sz #t)
                       (code "result_sz = p_sz;"
                             (statements (cdr l) config))]
                      [(measure)
                       (hashtable-set! (lookup 'used config) 'p_sz #t)
                       (code "measure_total += p_sz;"
                             (statements (cdr l) config))]
                      [else (statements (cdr l) config)])]
                   [used? (hashtable-ref (lookup 'used config) 'p_sz #f)])
              (hashtable-set! (lookup 'used config) 'p_sz was-used?)
              (cond
                [used?
                 (code-block
                  (format "uptr p_sz = ~a;" (let ([s (size-expression sz config)])
                                              (if (= scale 1)
                                                  s
                                                  (format "~a * (~a)" scale s))))
                  rest)]
                [else rest]))]
           [`(skip-forwarding)
            (case (lookup 'mode config)
              [(copy)
               (unless (null? (cdr l))
                 (error 'skip-forwarding "not at end"))
               (code "return new_p;")]
              [else
               (statements (cdr l) config)])]
           [`(mark . ,flags)
            (for-each (lambda (flag)
                        (unless (memq flag '(one-bit no-sweep within-segment counting-root))
                          (error 'mark "bad flag ~s" flag)))
                      flags)
            (case (lookup 'mode config)
              [(mark)
               (let* ([count-stmt (let loop ([l (cdr l)])
                                   (cond
                                     [(null? l) (error 'mark "could not find `count` or `as-mark-end` ~s" config)]
                                     [else
                                      (match (car l)
                                        [`(count . ,rest) (car l)]
                                        [`(as-mark-end . ,stmts) (car l)]
                                        [`(case-mode . ,all-clauses)
                                         (let ([body (find-matching-mode 'mark all-clauses)])
                                           (loop (append body (cdr l))))]
                                        [`(,id . ,args)
                                         (let ([m (eq-hashtable-ref trace-macros id #f)])
                                           (if m
                                               (loop (append (apply-macro m args)
                                                             (cdr l)))
                                               (loop (cdr l))))]
                                        [else (loop (cdr l))])]))])
                 (code
                  (mark-statement flags config)
                  (statements (list count-stmt) config)))]
              [else
               (statements (cdr l) config)])]
           [`(define ,id : ,type ,rhs)
            (let* ([used (lookup 'used config)]
                   [prev-used? (hashtable-ref used id #f)])
              (hashtable-set! used id #f)
              (let* ([rest (statements (cdr l) config)]
                     [used? (hashtable-ref (lookup 'used config) id #f)])
                (hashtable-set! used id prev-used?)
                (if used?
                    (code-block (code-indent (format "~a ~a = " type id)
                                             (expression rhs config #f #t)
                                             ";")
                                rest)
                    rest)))]
           [`(cond . ,clauses)
            (code
             (let loop ([clauses clauses] [else? #f])
               (match clauses
                 [`() (code)]
                 [`([else . ,rhss])
                  (cond
                    [(null? rhss)
                     (code)]
                    [else
                     (if else?
                         (code "else"
                               (code-block
                                (statements rhss config)))
                         (statements rhss config))])]
                 [`([,test . ,rhss] . ,clauses)
                  (let ([tst (expression test config)])
                    (cond
                      [(equal? tst "0")
                       (loop clauses else?)]
                      [else
                       (let ([rhs (statements rhss config)])
                         (cond
                           [(equal? tst "1")
                            (if else?
                                (code-block "else" rhs)
                                rhs)]
                           [else
                            (code (format "~aif (~a)" (if else? "else " "") tst)
                                  (code-block rhs)
                                  (loop clauses #t))]))]))]))
             (statements (cdr l) config))]
           [`(let* ,binds . ,body)
            (code
             (code-block
              (let loop ([binds binds])
                (match binds
                  [`() (statements body config)]
                  [`([,id : ,type ,rhs] . ,binds)
                   (code (code-indent (format "~a ~a = " type id)
                                      (expression rhs config #f #t)
                                      ";")
                         (loop binds))])))
             (statements (cdr l) config))]
           [`(while :? ,tst . ,body)
            (code (format "while (~a)" (expression tst config))
                  (code-block
                   (statements body config))
                  (statements (cdr l) config))]
           [`(do-while . ,body+test)
            (let-values ([(body tst)
                          (let loop ([body+test body+test] [rev-body '()])
                            (match body+test
                              [`(:? ,test) (values (reverse rev-body) test)]
                              [`(,e . ,rest)
                               (loop rest (cons e rev-body))]))])
              (code "do"
                    (code-block
                     (statements body config))
                    (format "while (~a);"  (expression tst config))
                    (statements (cdr l) config)))]
           [`(when ,tst . ,body)
            (statements (cons `(cond [,tst . ,body][else]) (cdr l))
                        config)]
           [`(set! ,lhs ,rhs)
            (code (code-indent (format "~a = "
                                       (expression lhs config))
                               (expression rhs config #f #t)
                               ";")
                  (statements (cdr l) config))]
           [`(set! ,lhs ,op ,rhs)
            (unless (memq op '(+= -= <<= >>=))
              (error 'set! "not an update op ~s" op))
            (code (format "~a ~a ~a;"
                          (expression lhs config)
                          op
                          (expression rhs config))
                  (statements (cdr l) config))]
           [`(break)
            (code "break;")]
           [`(assert ,expr)
            (unless (eval expr)
              (error 'assert "failed: ~s" expr))
            (statements (cdr l) config)]
           [`(,id . ,args)
            (let ([m (eq-hashtable-ref trace-macros id #f)])
              (if m
                  (statements (append (apply-macro m args)
                                      (cdr l))
                              config)
                  (code (format "~a;" (expression a config #f #t))
                        (statements (cdr l) config))))]
           [else
            (code (format "~a;" (expression a config #f #t))
                  (statements (cdr l) config))]))]))

  ;; S-expresison -> string
  (define expression
    (case-lambda
     [(a config) (expression a config #f #f)]
     [(a config protect?) (expression a config protect? #f)]
     [(a config protect? multiline?)
      (define (protect s)
        (if protect? (format "(~a)" s) s))
      (match a
        [`_ "p"]
        [`_copy_ (case (lookup 'mode config)
                   [(copy vfasl-copy) "new_p"]
                   [else "p"])]
        [`_tf_
         (lookup 'tf config "TYPEFIELD(p)")]
        [`_tg_
         (case (lookup 'mode config)
           [(copy) "tg"]
           [else "target_generation"])]
        [`_backreferences?_
         (if (lookup 'maybe-backreferences? config #f)
             "BACKREFERENCES_ENABLED"
             "0")]
        [`(just ,id)
         (hashtable-set! (lookup 'used config) id #t)
         (symbol->string id)]
        [`(case-flag ,flag
           [on ,on]
           [off ,off])
         (let ([e (if (lookup flag config #f)
                      on
                      off)])
           (expression e config protect? multiline?))]
        [`(case-mode . ,all-clauses)
         (match (find-matching-mode (lookup 'mode config) all-clauses)
           [`(,e)
            (expression e config protect? multiline?)]
           [`,any
            (error 'case-mode "bad form ~s" a)])]
        [`(cond . ,clauses)
         (let loop ([clauses clauses] [protect? protect?])
           (match clauses
             [`([else ,rhs]) (expression rhs config protect? multiline?)]
             [`([,test ,rhs] . ,clauses)
              (let ([tst (expression test config #t #t)])
                (cond
                  [(equal? tst "0")
                   (loop clauses protect?)]
                  [(equal? tst "1")
                   (expression rhs config protect? multiline?)]
                  [else
                   (if multiline?
                       (format "(~a\n ? ~a\n : ~a)"
                               tst
                               (indent-newlines (expression rhs config #t #t) 3)
                               (indent-newlines (loop clauses #t) 3))
                       (format "(~a ? ~a : ~a)"
                               tst
                               (expression rhs config #t #f)
                               (loop clauses #t)))]))]))]
        [`(cast ,type ,e)
         (protect (format "(~a)~a" type (expression e config #t)))]
        [`(array-ref ,array ,index)
         (protect (format "~a[~a]"
                          (expression array config #t)
                          (expression index config)))]
        [`(set! ,lhs ,rhs) ; a `set!` used as an expression
         (format "(~a = ~a)"
                 (expression lhs config #t)
                 (expression rhs config #t))]
        [`(,op ,a)
         (cond
           [(memq op '(& - !))
            (protect (format "~a~a" op (expression a config #t)))]
           [(get-offset-value op)
            => (lambda (v)
                 (protect (field-ref-expression (expression a config) v op #f config)))]
           [(eq-hashtable-ref trace-macros op #f)
            => (lambda (m)
                 (expression (car (apply-macro m (list a))) config protect? multiline?))]
           [else
            (protect (format "~a(~a)" op (expression a config #t)))])]
        [`(,op ,a ,b)
         (cond
           [(memq op '(& && \|\| == != + - * < > <= >= << >> ->))
            (protect (format "~a ~a ~a" (expression a config #t) op (expression b config #t)))]
           [(get-offset-value op)
            => (lambda (v)
                 (protect (field-ref-expression (expression a config) v op b config)))]
           [else
            (protect (format "~a(~a, ~a)" op (expression a config) (expression b config)))])]
        [`(,rator . ,rands)
         (unless (symbol? rator)
           (error 'expression "expected a symbol for funciton name: ~s" rator))
         (format "~a(~a)"
                 rator
                 (comma-ize (map (lambda (r) (expression r config)) rands)))]
        [else
         (cond
           [(eq? a #f) "Sfalse"]
           [(eq? a #t) "Strue"]
           [(symbol? a)
            (cond
              [(getprop a '*c-name* #f)
               => (lambda (c-name) c-name)]
              [else
               (hashtable-set! (lookup 'used config) a #t)
               (symbol->string a)])]
           [else
            (format "~s" a)])])]))

  (define (find-matching-mode mode all-clauses)
    (let loop ([clauses all-clauses])
      (match clauses
        [`([else . ,body])
         body]
        [`([,cl-mode . ,cl-body] . ,clauses)
         (if (or (eq? cl-mode mode)
                 (and (pair? cl-mode)
                      (memq mode cl-mode)))
             cl-body
             (loop clauses))]
        [`()
         (error 'case-mode "no matching case for ~s in ~s" mode all-clauses)])))

  (define (loop-over-pointers ptr-e len body config)
    (code-block
     (format "uptr idx, p_len = ~a;" (expression len config))
     (format "ptr *p_p = &~a;" ptr-e)
     "for (idx = 0; idx < p_len; idx++)"
     (code-block body)))

  (define (trace-statement field config early?)
    (define mode (lookup 'mode config))
    (cond
      [(or (eq? mode 'sweep)
           (eq? mode 'vfasl-sweep)
           (and early? (or (eq? mode 'copy)
                           (eq? mode 'mark))))
       (relocate-statement (field-expression field config "p" #t) config)]
      [(or (eq? mode 'copy)
           (eq? mode 'vfasl-copy))
       (copy-statement field config)]
      [(eq? mode 'measure)
       (measure-statement (field-expression field config "p" #f))]
      [(eq? mode 'self-test)
       (format "if (p == ~a) return 1;" (field-expression field config "p" #f))]
      [else #f]))

  (define (relocate-statement e config)
    (define mode (lookup 'mode config))
    (case mode
      [(vfasl-sweep)
       (format "vfasl_relocate(vfi, &~a);" e)]
      [else
       (if (lookup 'as-dirty? config #f)
           (format "relocate_dirty(&~a, tg, youngest);" e)
           (format "relocate(&~a);" e))]))

  (define (measure-statement e)
    (code
     "{ /* measure */"
     (format "  ptr r_p = ~a;" e)
     "  if (!IMMEDIATE(r_p))"
     "    push_measure(r_p);"
     "}"))

  (define (copy-statement field config)
    (define mode (lookup 'mode config))
    (case mode
      [(copy vfasl-copy)
       (cond
         [(symbol? field)
          (unless (lookup 'copy-ready? config #f)
            (error 'copy "need size before: ~s" field))
          (format "~a = ~a;"
                  (field-expression field config "new_p" #f)
                  (field-expression field config "p" #f))]
         [else
          (when (eq? mode 'copy)
            (error 'copy "pointless copy to self for ~s" field))
          #f])]
      [else #f]))

  (define (count-statement counter size scale modes config)
    (let* ([real-mode (lookup 'mode config)]
           [mode (if (eq? real-mode 'mark) 'copy real-mode)])
      (cond
        [(or (eq? mode modes) (and (pair? modes) (memq mode modes)))
         (cond
           [(lookup 'counts? config #f)
            (let ([tg (if (eq? real-mode 'copy)
                          "tg"
                          "target_generation")])
              (code
               (format "S_G.countof[~a][~a] += ~a;" tg (as-c counter) scale)
               (if (lookup 'constant-size? config #f)
                   #f
                   (format "S_G.bytesof[~a][~a] += ~a;"
                           tg
                           (as-c counter)
                           (let ([s (if size
                                        (expression size config)
                                        (begin
                                          (hashtable-set! (lookup 'used config) 'p_sz #t)
                                          "p_sz"))])
                             (if (eqv? scale 1)
                                 s
                                 (format "~a * (~a)" scale s)))))))]
           [else #f])]
        [else #f])))

  (define (mark-statement flags config)
    (let* ([known-space (lookup 'known-space config #f)]
           [sz (let ([sz (lookup 'known-size config #f)])
                 (and sz (get-size-value sz)))]
           [one-bit? (or (memq 'one-bit flags)
                         (eq? 'space-data known-space)
                         (eqv? sz (constant byte-alignment)))]
           [within-segment? (or (memq 'within-segment flags)
                                (and sz
                                     (< sz (constant bytes-per-segment))))]
           [no-sweep? (or (memq 'no-sweep flags)
                          (eq? known-space 'space-data))]
           [within-loop-statement
            (lambda (decl si step count?)
              (code-block
               "uptr offset = 0;"
               "while (offset < p_sz) {"
               "  ptr mark_p = (ptr)((uptr)p + offset);"
               decl
               (format "  ~a->marked_mask[segment_bitmap_byte(mark_p)] |= segment_bitmap_bit(mark_p);" si)
               (and count? (format "  ~a->marked_count += ~a;" si step))
               (format "  offset += ~a;" step)
               "}"))]
           [type (let ([t (lookup 'basetype config)])
                   (if (eq? t 'typemod)
                       #f
                       (as-c 'type (lookup 'basetype config))))]
           [untype (lambda ()
                     (if type
                         (format "(uptr)UNTYPE(p, ~a)" type)
                         (format "(uptr)p")))])
      (hashtable-set! (lookup 'used config) 'p_sz #t)
      (code
       (cond
         [one-bit?
          (code
           "si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p);"
           (cond
             [within-segment?
              "si->marked_count += p_sz;"]
             [else
              (code-block
               (format "uptr addr = ~a;" (untype))
               "uptr seg = addr_get_segment(addr);"
               "uptr end_seg = addr_get_segment(addr + p_sz - 1);"
               "if (seg == end_seg) {"
               "  si->marked_count += p_sz;"
               "} else {"
               "  seginfo *mark_si;"
               "  si->marked_count += ((uptr)build_ptr(seg+1,0)) - addr;"
               "  seg++;"
               "  while (seg < end_seg) {"
               "    mark_si = SegInfo(seg);"
               "    if (!fully_marked_mask) init_fully_marked_mask();"
               "    mark_si->marked_mask = fully_marked_mask;"
               "    mark_si->marked_count = segment_bitmap_bytes;"
               "    seg++;"
               "  }"
               "  mark_si = SegInfo(end_seg);"
               (ensure-segment-mark-mask "mark_si" "  " '())
               "    /* no need to set a bit: just make sure `marked_mask` is non-NULL */"
               "  mark_si->marked_count += addr + p_sz - (uptr)build_ptr(end_seg,0);"
               "}")]))]
         [within-segment?
          (code
           "si->marked_count += p_sz;"
           (cond
             [sz
              (code-block
               "ptr mark_p = p;"
               (let loop ([sz sz])
                 (code
                  "si->marked_mask[segment_bitmap_byte(mark_p)] |= segment_bitmap_bit(mark_p);"
                  (let ([sz (- sz (constant byte-alignment))])
                    (if (zero? sz)
                        #f
                        (code
                         "mark_p = (ptr)((uptr)mark_p + byte_alignment);"
                         (loop sz)))))))]
             [else
              (within-loop-statement #f "si" "byte_alignment" #f)]))]
         [else
          (let ([step "byte_alignment"])
            (code-block
             (format "uptr addr = (uptr)UNTYPE(p, ~a);" type)
             "if (addr_get_segment(addr) == addr_get_segment(addr + p_sz - 1))"
             (code-block
              "si->marked_count += p_sz;"
              (within-loop-statement #f "si" step #f))
             "else"
             (within-loop-statement (code
                                     "  seginfo *mark_si = SegInfo(ptr_get_segment(mark_p));"
                                     (ensure-segment-mark-mask "mark_si" "  " '()))
                                    "mark_si"
                                    step
                                    #t)))])
       (cond
         [no-sweep? #f]
         [else
          (let ([push "push_sweep(p);"])
            (cond
              [(and (memq 'counting-root flags)
                    (lookup 'counts? config #f))
               (code "if (!is_counting_root(si, p))"
                     (code-block push))]
              [else push]))]))))

  (define (field-expression field config arg protect?)
    (if (symbol? field)
        (cond
          [(get-offset-value field)
           => (lambda (v)
                (field-ref-expression arg v field 0 config))]
          [else
           (error 'field "identifier is not a field accessor: ~s" field)])
        (expression field config protect?)))

  (define (size-expression sz config)
    (if (symbol? sz)
        (cond
          [(get-size-value sz)
           => (lambda (v) (as-c sz))]
          [else
           (error 'size "identifier is not a size: ~s" sz)])
        (expression sz config)))

  (define (field-ref-expression obj v acc-name index config)
    (let ([c-ref (getprop acc-name '*c-ref* #f)])
      (unless c-ref
        (error 'field-ref "could not find accessor for ~s" acc-name))
      (cond
        [(pair? c-ref)
         (unless index
           (error 'field-ref "missing index for array field ~s" acc-name))
         (format "~a(~a, ~a)" (car c-ref) obj (expression index config))]
        [else
         (when (and index (not (eq? index 0)))
           (error 'field-ref "index not allowed for non-array field ~s" acc-name))
         (format "~a(~a)" c-ref obj)])))
  
  (define (ensure-segment-mark-mask si inset flags)
    (code
     (format "~aif (!~a->marked_mask) {" inset si)
     (format "~a  find_room(space_data, target_generation, typemod, ptr_align(segment_bitmap_bytes), ~a->marked_mask);"
             inset si)
     (if (memq 'no-clear flags)
         (format "~a  /* no clearing needed */" inset)
         (format "~a  memset(~a->marked_mask, 0, segment_bitmap_bytes);" inset si))
     (format "~a}" inset)))

  (define (just-mark-bit-space? sp)
    (case sp
      [(space-symbol space-port) #t]
      [else (atomic-space? sp)]))

  (define (atomic-space? sp)
    (case sp
      [(space-data) #t]
      [else #f]))

  ;; Slightly hacky way to check whether `op` is an accessor
  (define (get-offset-value op)
    (getprop (string->symbol (format "~a-disp" op)) '*constant* #f))

  ;; Check whether `op` is a size (probably)
  (define (get-size-value op)
    (getprop op '*constant* #f))

  ;; Convert to C constant name
  (define as-c
    (case-lambda
     [(sym)
      (or (getprop sym '*c-name* #f)
          (error 'as-type "failed for ~s" sym))]
     [(prefix base)
      (or (getprop (string->symbol (format "~a-~a" prefix base)) '*c-name* #f)
          (error 'as-type "failed for ~s ~s" prefix base))]))

  (define (comma-ize l)
    (apply string-append
           (let loop ([l l])
             (if (null? l)
                 '("")
                 (if (null? (cdr l))
                     (list (car l))
                     (list* (car l) ", " (loop (cdr l))))))))

  (define (apply-macro m l)
    (define args (car m))
    (define body (cdr m))
    (unless (= (length args) (length l))
      (error 'apply-macro "wrong macro argument count: ~s vs ~s" args l))
    (let ([subs (map cons args l)])
      (let loop ([m body])
        (cond
          [(symbol? m)
           (let ([a (assq m subs)])
             (if a
                 (cdr a)
                 m))]
          [(pair? m)
           (cons (loop (car m)) (loop (cdr m)))]
          [else m]))))

  (define (type-included? type config)
    (let ([types (lookup 'known-types config #f)])
      (if (not types)
          #t
          (memq type types))))

  (define (prune types config)
    (let loop ([types types])
      (if (null? types)
          '()
          (let ([s (prune-one (car types) config)])
            (if s
                (cons s (loop (cdr types)))
                (loop (cdr types)))))))

  (define (prune-one type config)
    (define known-types (lookup 'known-types config #f))
    (cond
      [(or (not known-types)
           (memq (car type) known-types))
       (let ([known-space (lookup 'known-space config #f)])
         (cond
           [(or (not known-space)
                (body-has-space? (cdr type) known-space config))
            type]
           [else #f]))]
      [else #f]))

  (define (body-has-space? body space config)
    (cond
      [(null? body) (error 'base-has-space? "no `space` specification in body")]
      [else
       (let ([a (car body)])
         (cond
           [(and (pair? a) (eq? (car a) 'space))
            (body-has-tail? (cdr a) space config)]
           [(and (pair? a) (memq (car a) '(case-space cond)))
            (unless (null? (cdr body)) (error 'body-has-space? "there's more?"))
            (let loop ([clauses (cdr a)])
              (if (null? clauses)
                  #f
                  (or (body-has-space? (cdar clauses) space config)
                      (loop (cdr clauses)))))]
           [else
            (body-has-space? (cdr body) space config)]))]))

  (define (body-has-tail? body key config)
    (cond
      [(null? body) #f]
      [else
       (let ([a (car body)])
         (match a
           [`(cond . ,clauses)
            (ormap (lambda (clause)
                     (body-has-tail? (cdr clause) key config))
                   clauses)]
           [else
            (body-has-tail? (cdr body) key config)]))]))

  (define print-code
    (case-lambda
     [(c)
      (print-code c 0)
      (newline)]
     [(c indentation)
      (cond
        [(not c) (void)]
        [(seq? c)
         (for-each (lambda (p)
                     (print-code p indentation))
                   (seq-l c))]
        [(block-seq? c)
         (let ([l (block-seq-l c)])
           (cond
             [(and (pair? l)
                   (null? (cdr l))
                   (block-seq? (car l)))
              (print-code (car l) indentation)]
             [else
              (indent indentation)
              (printf "{\n")
              (for-each (lambda (p)
                          (print-code p (+ indentation 2)))
                        l)
              (indent indentation)
              (printf "}\n")]))]
        [(indent-seq? c)
         (indent indentation)
         (printf "~a" (indent-seq-pre c))
         (printf "~a" (indent-newlines (indent-seq-mid c)
                                       (+ indentation (string-length (indent-seq-pre c)))))
         (printf "~a" (indent-seq-post c))
         (newline)]
        [else
         (indent indentation)
         (printf "~a\n" (indent-newlines c indentation))])]))

  (define (indent n)
    (display (make-string n #\space)))

  (define (indent-newlines s n)
    (list->string
     (let loop ([l (string->list s)])
       (cond
         [(null? l) '()]
         [(eqv? #\newline (car l))
          (cons #\newline (append (string->list (make-string n #\space))
                                  (loop (cdr l))))]
         [else (cons (car l) (loop (cdr l)))]))))

  (define (gen-gc ofn count? measure?)
    (guard
     (x [#t (raise x)])
     (parameterize ([current-output-port (open-output-file ofn 'replace)])
       (print-code (generate "copy"
                             `((mode copy)
                               (maybe-backreferences? ,count?)
                               (counts? ,count?))))
       (print-code (generate "sweep"
                             `((mode sweep)
                               (maybe-backreferences? ,count?)
                               (counts? ,count?))))
       (print-code (generate "sweep_dirty_object"
                             `((mode sweep)
                               (maybe-backreferences? ,count?)
                               (counts? ,count?)
                               (as-dirty? #t))))
       (letrec ([sweep1
                 (case-lambda
                  [(type) (sweep1 type (format "sweep_~a" type) '())]
                  [(type name) (sweep1 type name '())]
                  [(type name extra-configs)
                   (print-code (generate name
                                         (append
                                          extra-configs
                                          `((mode sweep)
                                            (known-types (,type))
                                            (maybe-backreferences? ,count?)
                                            (counts? ,count?)))))])])
         (sweep1 'record "sweep_record" '((rtd-relocated? #t)))
         (sweep1 'record "sweep_dirty_record" '((rtd-relocated? #t)
                                                (as-dirty? #t)))
         (sweep1 'symbol)
         (sweep1 'symbol "sweep_dirty_symbol" '((as-dirty? #t)))
         (sweep1 'thread)
         (sweep1 'port)
         (sweep1 'port "sweep_dirty_port" '((as-dirty? #t)))
         (sweep1 'closure "sweep_continuation" '((code-relocated? #t)
                                                 (assume-continuation? #t)))
         (sweep1 'code "sweep_code_object"))
       (print-code (generate "size_object"
                             `((mode size))))
       (print-code (generate "mark_object"
                             `((mode mark)
                               (counts? ,count?))))
       (print-code (generate "object_directly_refers_to_self"
                             `((mode self-test))))
       (print-code (code "static void mark_typemod_data_object(ptr p, uptr p_sz, seginfo *si)"
                         (code-block
                          (ensure-segment-mark-mask "si" "" '())
                          (mark-statement '(one-bit no-sweep)
                                          (cons
                                           (list 'used (make-eq-hashtable))
                                           '((basetype typemod)))))))
       (when measure?
         (print-code (generate "measure" `((mode measure))))))))

  (define (gen-vfasl ofn)
    (guard
     (x [#t (raise x)])
     (parameterize ([current-output-port (open-output-file ofn 'replace)])
       (print-code (generate "copy"
                             `((mode vfasl-copy))))
       (print-code (generate "sweep"
                             `((mode vfasl-sweep)
                               (return-size? #t)))))))

  ;; Render via mkequates to record a mapping from selectors to C
  ;; macros:
  (let-values ([(op get) (open-bytevector-output-port (native-transcoder))])
    (mkequates.h op))
  
  (set! mkgc-ocd.inc (lambda (ofn) (gen-gc ofn #f #f)))
  (set! mkgc-oce.inc (lambda (ofn) (gen-gc ofn #t #t)))
  (set! mkvfasl.inc (lambda (ofn) (gen-vfasl ofn))))