58282cbb5f
The problem especially affects `enable-object-counts`, where mark mode can update an old rtd instead of a copy that is already made. original commit: 31e2df63894d39b005c6b9984745b44409198d02
2488 lines
93 KiB
Scheme
2488 lines
93 KiB
Scheme
;; 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-for-vfasl (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 (abs-for-vfasl e)
|
|
(case-mode
|
|
[vfasl-sweep reloc_abs]
|
|
[else e]))
|
|
|
|
(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))))
|