152 lines
2.0 KiB
Scheme
152 lines
2.0 KiB
Scheme
;; Note that this is scheme syntax wrapping asm for a stack machine
|
|
(variable eol 0)
|
|
(variable scan 0)
|
|
(variable free 0)
|
|
;; These need to be initialized with the runtime
|
|
(variable eom 0)
|
|
(variable old 0)
|
|
(variable new 0)
|
|
(variable root 0)
|
|
|
|
(push main)
|
|
(jmp)
|
|
|
|
alloc ;; ( -- p)
|
|
;; Test if free will go beyond eom
|
|
(ref free)
|
|
(dup) ; ( -- free free)
|
|
(push 8)
|
|
(+)
|
|
(dup) ; ( -- free free+8 free+8)
|
|
(ref eom)
|
|
(<) ; ( -- free free+8 (free+8 < eom))
|
|
(push alloc-do-gc)
|
|
(if)
|
|
;; write free+8 to free
|
|
(set! free)
|
|
;; return the old free, it is memory the program can use
|
|
(return)
|
|
alloc-do-gc
|
|
;; Empty the stack
|
|
(drop)
|
|
(drop)
|
|
;; Run garbage collection
|
|
(push gc-run)
|
|
(call)
|
|
;; Tail-call allocation
|
|
(push alloc)
|
|
(jmp)
|
|
|
|
gc-run ;; ( -- )
|
|
; Move scan & free to start of new memory
|
|
(ref new)
|
|
(dup)
|
|
(set! free)
|
|
(set! scan)
|
|
(ref root)
|
|
(push relocate-cons)
|
|
(call)
|
|
(push gc-loop)
|
|
(call)
|
|
; Flip old and new
|
|
(ref old)
|
|
(dup)
|
|
(ref new)
|
|
(set! old)
|
|
(set! new)
|
|
(push 512)
|
|
(+)
|
|
(set! eom)
|
|
(return)
|
|
|
|
relocate-cons ;; (o -- )
|
|
(dup)
|
|
(@)
|
|
(push relocate-reg)
|
|
(call)
|
|
(push 4)
|
|
(+)
|
|
(@)
|
|
(push relocate-reg)
|
|
|
|
relocate-reg ;; (r -- )
|
|
(dup)
|
|
(push #x80000000) ;; Is this a cons?
|
|
(and)
|
|
(push reg-relocated)
|
|
(if)
|
|
(dup)
|
|
(ref eol)
|
|
(=) ;; Is this eol?
|
|
(not)
|
|
(push reg-relocated)
|
|
(if)
|
|
(dup)
|
|
(push #x40000000) ;; Is it a broken heart?
|
|
(and)
|
|
(push copy-and-construct)
|
|
(if)
|
|
(dup) ;; Broken heart, copy updated address from cdr
|
|
(push 4)
|
|
(+)
|
|
(@) ;; Retrieve new address
|
|
(dup)
|
|
(!) ;; Write it here
|
|
(push reg-relocated)
|
|
(jmp)
|
|
copy-and-construct
|
|
(dup) ;; Wasn't a broken heart, move car to new memory
|
|
(@)
|
|
(push free)
|
|
(!)
|
|
(dup) ;; Push cdr to new memory
|
|
(push 4)
|
|
(+)
|
|
(@)
|
|
(push free)
|
|
(push 4)
|
|
(+)
|
|
(!)
|
|
(push #x40000000)
|
|
(over)
|
|
(!)
|
|
(ref free)
|
|
(over)
|
|
(push 4)
|
|
(+)
|
|
(!)
|
|
(ref free) ;; Move free pointer
|
|
(push 8)
|
|
(+)
|
|
(set! free)
|
|
reg-relocated
|
|
(drop)
|
|
(return)
|
|
|
|
gc-loop
|
|
(ref free)
|
|
(ref scan)
|
|
(<)
|
|
(branch gc-loop-done)
|
|
(ref scan)
|
|
(relocate-reg)
|
|
(push gc-loop)
|
|
(jmp)
|
|
gc-loop-done
|
|
(return)
|
|
|
|
|
|
main
|
|
;; These need to be initialized with the runtime
|
|
(push memory)
|
|
(dup)
|
|
(set! new)
|
|
(push 512)
|
|
(+)
|
|
(dup)
|
|
(set! eom)
|
|
(set! old)
|
|
;; TODO set up root
|
|
|
|
memory
|