Multitasking

lib/util.fnl

@@ -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}
 

neutgs/init.fnl

@@ -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 (number-printer (new-task (ref print-numbers-forever)))
-    (let (i 0)
+      (wait-for-key)
-      (while (< screen-offset screen-size)
+      (reset-task number-printer (ref yield-forever)))
-        (set! screen-cursor (+ screen-offset i))
+
-        (set! i (+ i 1))))
+;     (GrafOff)
-    (wait-for-key)
-    (GrafOff)
 
     (EMShutDown)
     (QDShutDown)

ssc/iigs/bootstub.fnl

@@ -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
    ))
 

ssc/init.fnl

@@ -37,14 +37,7 @@
 (local Ssc (Object:extend))
 (local Prg (require :asm.asm))
 (local util (require :lib.util))
-(local {: loword : hiword : pairoff} util)
+(local {: loword : hiword : pairoff : countiter} 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)
 
 (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))
+  (set self.dp-vars 0)
-    (self:compile (!
+  (set self.LONG_LO (self:alloc-dp-var))
-      (start-symbol boot)
+  (set self.LONG_HI (self:alloc-dp-var))
-      (org [(or opts.boot-org 0)])
+  (set self.ADDR_LO (self:alloc-dp-var))
-      (asm
+  (set self.ADDR_HI (self:alloc-dp-var)))
-        boot
+
-        (clc) (xce) (rep 0x30) ; disable emulation mode, 16-bit index registers
+(fn Ssc.alloc-dp-var [self]
-        (jsr [(or opts.main :main)])
+  (let [addr (.. :d self.dp-vars)]
-        (sec) (xce) ;re-enter emulation mode
+    (set self.dp-vars (+ self.dp-vars 2))
-        (rts))))))
+    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))]
+                compiled-cleanup      (icollect [i-half (countiter (/ (length bindings) 2))]
-                                       (self:drop (. bindings (- (length bindings) (* i-half 2) -1))))]
+                                        (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 true) (self:opgen-const self.constants.true)
-      (= expr false) (self:opgen-const self.FALSE)
+      (= 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)]

ssc/task.fnl

@@ -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))))