SpindleyQ/honeylisp
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Multitasking

Browse source
This commit is contained in:
Jeremy Penner 2021-08-19 23:51:12 -04:00
parent 64281801b2
commit c428ef3d9c
5 changed files with 108 additions and 47 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
lib/util.fnl
View file

@ -120,8 +120,15 @@
(fn [_ iprev] (let [i (if iprev (+ iprev 2) 1)]
(when (< i (length l)) (values i (. l i) (. l (+ i 1)))))))
(fn countiter [minmax ?max]
(let [min (if ?max minmax 1)
max (or ?max minmax)]
(fn [_ iprev]
(let [i (if iprev (+ iprev 1) min)]
(when (<= i max) i)))))
{: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24
: splice : lo : hi : loword : hiword
: reload : hotswap : swappable :require swappable-require : hot-table : nested-tset : pairoff
: reload : hotswap : swappable :require swappable-require : hot-table : nested-tset : pairoff : countiter
: readjson : writejson : file-exists : waitfor : in-coro : multival}

29
neutgs/init.fnl
View file

@ -1,9 +1,10 @@
(local Ssc (require :ssc))
(import-macros {:sss ! : compile} :ssc.macros)
(local ssc (Ssc {:boot [(! (require ssc.iigs.bootstub))]}))
(local ssc (Ssc))
(compile ssc
(require :ssc.iigs.toolbox)
(require ssc.iigs.bootstub)
(require ssc.iigs.toolbox)
(tooltable toolsets
ToolsetIntegerMath 0x0100
@ -31,7 +32,8 @@
(fn wait-for-key ()
(FlushEvents keyDownMask 0)
(while (not (GetNextEvent keyDownMask (far-ref event-buffer)))))
(while (not (GetNextEvent keyDownMask (far-ref event-buffer)))
(yield)))
(const screen-addr 0xe12000)
(const screen-size 0x9d00)
@ -43,6 +45,13 @@
(set! screen-offset (+ screen-offset 2)))
(global word userID)
(fn print-numbers-forever ()
(let (i 0) (while true
(printnum i)
(yield)
(set! i (+ i 1)))))
(fn main ()
(LoadTools (far-ref toolsets))
(set! userID (MMStartUp))
@ -50,15 +59,13 @@
(TextStartUp)
(QDStartUp 0x2100 0 0 userID)
(EMStartUp 0x2000 0 0 320 0 200 userID)
(GrafOn)
; (GrafOn)
(set! screen-offset 0)
(let (i 0)
(while (< screen-offset screen-size)
(set! screen-cursor (+ screen-offset i))
(set! i (+ i 1))))
(wait-for-key)
(GrafOff)
(let (number-printer (new-task (ref print-numbers-forever)))
(wait-for-key)
(reset-task number-printer (ref yield-forever)))
; (GrafOff)
(EMShutDown)
(QDShutDown)

8
ssc/iigs/bootstub.fnl
View file

@ -2,8 +2,9 @@
#(compile $1
(start-symbol boot)
(org 0x0800)
(org 0x1000)
(require ssc.iigs.toolbox)
(require ssc.task)
(global word BootUserID)
(global long BootHandle-00)
@ -12,6 +13,9 @@
(global long BootHandle-e1)
(fn boot ()
(asm (clc) (xce) (rep 0x30)) ; disable emulation mode, 16-bit index registers
(save-dp-sp)
(set-task-base 0x0800) ; space for 8 tasks
; http://www.1000bit.it/support/manuali/apple/technotes/pdos/tn.pdos.27.html
; When bootstrapping with no OS, we must reserve
(TLStartUp)
@ -34,6 +38,8 @@
(DeleteID BootUserID)
(MTShutDown)
(restore-dp-sp)
(asm (sec) (xce)) ; re-enter emulation mode
))

54
ssc/init.fnl
View file

@ -37,14 +37,7 @@
(local Ssc (Object:extend))
(local Prg (require :asm.asm))
(local util (require :lib.util))
(local {: loword : hiword : pairoff} util)
(set Ssc.LONG_LO :d0x00)
(set Ssc.LONG_HI :d0x02)
(set Ssc.ADDR_LO :d0x04)
(set Ssc.ADDR_HI :d0x06)
(set Ssc.TRUE 0xffff)
(set Ssc.FALSE 0)
(local {: loword : hiword : pairoff : countiter} util)
(fn Ssc.new [self ?opts]
(local opts (or ?opts {}))
@ -54,19 +47,19 @@
(set self.locals [])
(set self.modules {})
(set self.globals {})
(set self.constants {})
(set self.constants {:true 0xffff :false 0})
(set self.getters {})
(set self.setters {})
(if opts.boot (self:compile (table.unpack opts.boot))
(self:compile (!
(start-symbol boot)
(org [(or opts.boot-org 0)])
(asm
boot
(clc) (xce) (rep 0x30) ; disable emulation mode, 16-bit index registers
(jsr [(or opts.main :main)])
(sec) (xce) ;re-enter emulation mode
(rts))))))
(set self.dp-vars 0)
(set self.LONG_LO (self:alloc-dp-var))
(set self.LONG_HI (self:alloc-dp-var))
(set self.ADDR_LO (self:alloc-dp-var))
(set self.ADDR_HI (self:alloc-dp-var)))
(fn Ssc.alloc-dp-var [self]
(let [addr (.. :d self.dp-vars)]
(set self.dp-vars (+ self.dp-vars 2))
addr))
(fn Ssc.push [self name expr ?etype]
(let [opgen (if (= ?etype :register) {:lo #[:flatten]}
@ -104,13 +97,6 @@
(fn Ssc.defining? [self] (> (length self.locals) 0))
(fn countiter [minmax ?max]
(let [min (if ?max minmax 1)
max (or ?max minmax)]
(fn [_ iprev]
(let [i (if iprev (+ iprev 1) min)]
(when (<= i max) i)))))
; operations that work on the accumulator, like adc or sbc
; optimization strategy: keep the current result in the accumulator, work from the stack or immediate values
; 1. take "right" arguments and push them (unless already on stack, immediate, or absolute)
@ -194,7 +180,7 @@
[:block (self:gen-condition test whentrue whenfalse (+ depth 1) (and (= op :or) (not lastclause))) nextlabel])))
(error (.. "Internal error: can't handle conditional " op)))))
(fn Ssc.cmp-to-bool [self op ...] (self:expr-poly [:if [op ...] self.TRUE self.FALSE]))
(fn Ssc.cmp-to-bool [self op ...] (self:expr-poly [:if [op ...] true false]))
(fn Ssc.compile-function [self name args ...]
(assert (not (self:defining?)) "Can't nest function definitions")
@ -240,10 +226,10 @@
expr))))
(values c-body etype-body))
:let (fn [self bindings ...]
(let [compiled-bindings (icollect [_ symbol expr (pairoff bindings)] (self:push symbol expr))
(let [compiled-bindings (icollect [_ symbol expr (pairoff bindings)] (self:push symbol expr))
(compiled-body etype) (self:expr-poly [:do ...])
compiled-cleanup (icollect [i-half (countiter (/ (length bindings) 2))]
(self:drop (. bindings (- (length bindings) (* i-half 2) -1))))]
compiled-cleanup (icollect [i-half (countiter (/ (length bindings) 2))]
(self:drop (. bindings (- (length bindings) (* i-half 2) -1))))]
(values (lume.concat [:block] compiled-bindings [compiled-body] compiled-cleanup) etype)))
:fn (lambda [self name args ...] (tset self.functions name (self:compile-function name args ...)))
:if (lambda [self test iftrue ?iffalse]
@ -251,7 +237,6 @@
(c-false falsetype) (when ?iffalse (self:expr-poly ?iffalse))
etype (if (not= truetype falsetype) :void truetype)
block [:block (self:gen-condition test :-if-true- :-if-false-) :-if-true- c-true]
; _ (pp block)
cl-false (if ?iffalse [[:bra :-if-done-] :-if-false- c-false :-if-done-]
[:-if-false-])]
(values (lume.concat block cl-false) etype)))
@ -312,6 +297,7 @@
:long! (lambda [self ref value] [:block (self:push nil ref :word)
(self:expr-long value) [:ldy 0] [:lda self.LONG_LO] [:sta [1 :s] :y] [:iny] [:iny] [:lda self.LONG_HI] [:sta [1 :s] :y]
(self:drop)])
:long (lambda [self value] (values [:block (self:expr-word value) [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]] :long))
:word-at (lambda [self ref]
(local (c-ref etype) (self:expr-poly ref))
(if (= etype :word)
@ -402,8 +388,8 @@
(fn Ssc.opgen [self expr]
(if (= (type expr) :number) (self:opgen-const expr)
(= expr true) (self:opgen-const self.TRUE)
(= expr false) (self:opgen-const self.FALSE)
(= expr true) (self:opgen-const self.constants.true)
(= expr false) (self:opgen-const self.constants.false)
(and (= (type expr) :string) (. self.constants expr)) (self:opgen (. self.constants expr))
(self:opgen-lhs expr)))
@ -464,7 +450,7 @@
_ (error (.. "Unrecognized expression"))))]
(if success (values c-expr etype)
(let [{: filename : line} (or self.expr-metadata {:filename "<unknown>" :line "??"})]
(error (.. filename "@" line ": " (fv expr) "\n" c-expr))))))
(error (.. filename "@" line ": " c-expr "\n" (fv expr)))))))
(fn Ssc.expr-word [self expr]
(let [(c etype) (self:expr-poly expr)]

55
ssc/task.fnl Normal file
View file

@ -0,0 +1,55 @@
(import-macros {:sss ! : compile} :ssc.macros)
(local {: addr-parser} (require :asm.65816))
#(compile $1
[(do (set $1.TASK-NEXT ($1:alloc-dp-var))
(set $1.TASK-STACK ($1:alloc-dp-var))
(set $1.TASK-MAILBOX ($1:alloc-dp-var))
nil)]
(global word old-dp 0)
(global word old-sp 0)
(form save-dp-sp [#[:block [:tdc] [:sta :old-dp] [:tsc] [:sta :old-sp]]])
(form restore-dp-sp [#[:block [:lda :old-dp] [:tcd] [:lda :old-sp] [:tcs]]])
(const task-size 0x100)
(global word first-task)
(global word last-task)
(form set-task-base [(fn [ssc task-base]
[:block [:lda task-base] [:tcd]
[:sta ssc.TASK-NEXT] [:sta :first-task] [:sta :last-task]
[:lda (+ task-base 0xff)] [:tcs]])])
(fn yield ()
(asm (tsc) (sta [$1.TASK-STACK])
(lda [$1.TASK-NEXT]) (tcd)
(lda [$1.TASK-STACK]) (tcs)))
(fn yield-forever () (while true (yield)))
(fn reset-task (task f)
; setup stack
(word! (long (+ task 0xfe)) (- (ref yield-forever) 1)) ; allow tasks to return; rts adds one to the value on the stack for the next pc
(word! (long (+ task 0xfc)) (- f 1)) ; yield will return to this address
(word! (long (+ task [(addr-parser $1.TASK-STACK)])) (+ task 0xfb)) ; stack pointer is the next available location
(word! (long (+ task [(addr-parser $1.TASK-MAILBOX)])) 0) ; clear mailbox
)
(fn new-task (f)
(let (next-task (+ last-task task-size))
(reset-task next-task f)
(word! (long (+ next-task [(addr-parser $1.TASK-NEXT)])) first-task) ; the last task yields to the first task, round-robin
(word! (long (+ last-task [(addr-parser $1.TASK-NEXT)])) next-task) ; the previously-last task now yields to us
(set! last-task next-task)
next-task))
(form current-task [#[:tdc]])
(fn task-send (task msg)
(word! (long (+ task [(addr-parser $1.TASK-MAILBOX)])) msg))
(form task-peek [#[:lda $1.TASK-MAILBOX]])
(fn task-recv ()
(asm (ldx [$1.TASK-MAILBOX]) (lda 0) (sta [$1.TASK-MAILBOX]) (txa))))