implement draw-object & pei slamming

asm: allow computed addresses, not just immediate mode values
map llissp source to assembly

asm/65816.fnl

@@ -50,8 +50,17 @@
     (tonumber (addr:sub 2))))
 (fn addr-parser [addr] (or (dp-addr addr) (tonumber addr)))
 
+(fn explicit-mode-arg [arg]
+  (var result nil)
+  (when (= (type arg) :table)
+    (each [mode arg (pairs arg)]
+      (when (= (type mode) :string)
+        (set result [mode arg]))))
+  result)
+
 (fn parse-mode-arg [op]
   (match op
+    (where [_ arg] (explicit-mode-arg arg)) (explicit-mode-arg arg)
     (where [mvx srcbank dstbank]
            (= (type srcbank) :number) (= (type dstbank) :number) (= (mvx:sub 1 2) :mv))
        [:bm [dstbank srcbank]] ; encoded backwards for some reason
@@ -90,8 +99,10 @@
 (fn addr-page [addr] (math.floor (/ addr 0x10000)))
 (fn op-pdat.patch [op env]
   (local long-mode (match op.mode :abs :abl :abx :alx))
-  (when (and long-mode (not= (addr-page (env:lookup-org op.arg))
+  (when (and long-mode
-                             (addr-page env.root-block.org)))
+             (not= (type op.arg) :function)
+             (not= (addr-page (env:lookup-org op.arg))
+                   (addr-page env.root-block.org)))
     (set op.mode long-mode)))
 
 (fn op-pdat.size [op env]
@@ -110,19 +121,18 @@
   (local bytegen (. opcodes op.opcode))
   (if bytegen
     (let [opbyte (bytegen op.mode)
+          arg (if (= (type op.arg) :function) (op.arg env) op.arg)
           argbytes
           (if
-            (or (= op.mode :sr) (= op.mode :isy)) (int8-to-bytes op.arg)
+            (or (= op.mode :sr) (= op.mode :isy)) (int8-to-bytes arg)
-            (= op.mode :bm) (.. (int8-to-bytes (. op.arg 1)) (int8-to-bytes (. op.arg 2)))
+            (= op.mode :bm) (.. (int8-to-bytes (. arg 1)) (int8-to-bytes (. arg 2)))
-            (and (= op.mode :imm) (= (type op.arg) "function"))
+            (and (= op.mode :imm) (= (op-pdat.size op env) 3)) (int16-to-bytes arg)
-              (int16-to-bytes (op.arg env))
+            (and (= op.mode :imm) (= (op-pdat.size op env) 2)) (int8-to-bytes arg)
-            (and (= op.mode :imm) (= (op-pdat.size op env) 3)) (int16-to-bytes op.arg)
+            (= op.mode :rel)  (int8-to-bytes (- (env:lookup-addr arg) (+ op.addr 2)))
-            (and (= op.mode :imm) (= (op-pdat.size op env) 2)) (int8-to-bytes op.arg)
+            (= op.mode :rell) (int16-to-bytes (- (env:lookup-addr arg) (+ op.addr 3)))
-            (= op.mode :rel)  (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
+            (= (op-pdat.size op env) 2) (int8-to-bytes (env:lookup-addr arg))
-            (= op.mode :rell) (int16-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 3)))
+            (= (op-pdat.size op env) 3) (int16-to-bytes (env:lookup-addr arg))
-            (= (op-pdat.size op env) 2) (int8-to-bytes (env:lookup-addr op.arg))
+            (= (op-pdat.size op env) 4) (int24-to-bytes (env:lookup-addr arg))
-            (= (op-pdat.size op env) 3) (int16-to-bytes (env:lookup-addr op.arg))
-            (= (op-pdat.size op env) 4) (int24-to-bytes (env:lookup-addr op.arg))
             "")]
       (if opbyte
         (.. (int8-to-bytes opbyte) argbytes)

asm/asm.fnl

@@ -49,11 +49,14 @@
 
         (let [opcode (. dat 1)
               parser (. dat-parser opcode)
+              meta (getmetatable dat)
               pdat
               (if parser (parser dat block)
                   (. opcodes opcode) (dat-parser.op dat)
                   (error (.. "Unrecognized opcode " (fv opcode))))]
           (when pdat
+            (when meta (set block.last-meta meta))
+            (set pdat.meta block.last-meta)
             (set pdat.nearest-symbol block.last-symbol)
             (table.insert block.pdats pdat)
             (when pdat.globals
@@ -106,10 +109,14 @@
     :pad {}
   })
 
+  (fn describe-pdat [pdat]
+    (if pdat.meta (.. pdat.meta.filename "@" pdat.meta.line)
+      (.. (or pdat.nearest-symbol "<start of block>") " @" (or pdat.addr "<no address>"))))
+
   (fn process-pdat [pdat process default ...]
     (fn complain [ok ...]
       (if ok (values ...)
-          (do (error (.. process " failed in " pdat.type " near " (or pdat.nearest-symbol "<start of block>") " @" (or pdat.addr "<no address>") " - " ...)))))
+          (do (error (.. process " failed in " pdat.type " near " (describe-pdat pdat) " - " ...)))))
     (local processor (. pdat-processor pdat.type process))
     (if processor (complain (pcall #(processor pdat $...) ...)) default))
 

lib/util.fnl

@@ -120,12 +120,13 @@
   (fn [_ iprev] (let [i (if iprev (+ iprev 2) 1)]
                           (when (< i (length l)) (values i (. l i) (. l (+ i 1)))))))
 
-(fn countiter [minmax ?max]
+(fn countiter [minmax ?max ?step]
   (let [min (if ?max minmax 1)
-        max (or ?max minmax)]
+        max (or ?max minmax)
+        step (or ?step 1)]
     (fn [_ iprev]
-      (let [i (if iprev (+ iprev 1) min)]
+      (let [i (if iprev (+ iprev step) min)]
-        (when (<= i max) i)))))
+        (when (if (> step 0) (<= i max) (>= 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

neutgs/init.fnl

@@ -7,6 +7,7 @@
 (compile ssc
   (require ssc.iigs.bootstub)
   (require ssc.iigs.toolbox)
+  (require ssc.iigs.graphics)
 
   (tooltable toolsets
     ToolsetIntegerMath  0x0100
@@ -50,12 +51,27 @@
     (asm
       (lda 16) (sta [ssc.LONG_LO]) (clc)
       (lda tile) (tax) (lda addr) (tay)
+      (phb)
       (bra draw)
     loop
       (tya) (adc 152) (tay)
     draw
-      (lda 7) (mvn 0 0xe1)
+      (lda 7) (mvn 6 1)
-      (dec [ssc.LONG_LO]) (bne loop)))
+      (dec [ssc.LONG_LO]) (bne loop)
+      (plb)))
+
+  (fn shadow-rewrite-tile (addr)
+    (asm
+      (lda 16) (sta [ssc.LONG_LO]) (clc)
+      (lda addr) (tay) (tax)
+      (phb)
+      (bra draw)
+    loop
+      (tya) (adc 152) (tay) (tax)
+    draw
+      (lda 7) (mvn 1 1)
+      (dec [ssc.LONG_LO]) (bne loop)
+      (plb)))
 
   (global word userID)
 
@@ -65,9 +81,17 @@
       (yield)
       (set! i (+ i 1)))))
 
-  (form itile-to-tile [(fn [ssc itile] [:block (ssc:expr-word itile) [:asl] [:asl] [:asl] [:asl] [:asl] [:asl] [:asl] [:clc] [:adc #($1:lookup-addr :tiles)]])])
+  (form itile-to-tile [(fn [ssc itile]
+    [:block (ssc:expr-word itile) [:asl] [:asl] [:asl] [:asl] [:asl] [:asl] [:asl]
+            [:clc] [:adc #($1:lookup-addr :tiles)]])])
+
+  (fn enable-shadowing ()  (set! (word-at (ref :0xc035)) (& (word-at (ref :0xc035)) 0xfff1)))
+  (fn disable-shadowing () (set! (word-at (ref :0xc035)) (| (word-at (ref :0xc035)) 0x000e)))
+
+  (global word with-shadowing 0)
 
   (fn draw-test-tiles (i)
+    (when with-shadowing (disable-shadowing))
     (let (x 0 y 0 screen 0x2000)
       (while (< y 12)
         (draw-tile (itile-to-tile (& (+ x y i) 3)) screen)
@@ -76,7 +100,24 @@
           (do (set! x 0)
               (set! y (+ y 1))
               (set! screen (+ screen [(+ 8 (* 160 15))])))
-          (set! screen (+ screen 8))))))
+          (set! screen (+ screen 8)))))
+    (when with-shadowing
+      (enable-shadowing)
+      (if (= with-shadowing 1)
+          (let (x 0 y 0 screen 0x2000)
+            (while (< y 12)
+              (shadow-rewrite-tile screen)
+              (set! x (+ x 1))
+              (if (= x 20)
+                (do (set! x 0)
+                    (set! y (+ y 1))
+                    (set! screen (+ screen [(+ 8 (* 160 15))])))
+                (set! screen (+ screen 8)))))
+        (let (screen 0x9dff y 0)
+          (while (< y 200)
+            (draw-object screen pei-slam-scanline)
+            (set! screen (- screen 160))
+            (set! y (+ y 1)))))))
 
   (fn draw-test-tiles-forever ()
     (let (i 0)
@@ -98,10 +139,14 @@
     (SetAllSCBs 0)
 
     (wait-for-key)
+    (enable-shadowing)
     (let (tile-task (new-task (ref draw-test-tiles-forever)))
       (wait-for-key)
-      (set! (word-at (ref :0xc035)) (& (word-at (ref :0xc035)) 0xf7))
+      (set! with-shadowing 1)
       (wait-for-key)
+      (set! with-shadowing 2)
+      (wait-for-key)
+      (set! with-shadowing false)
       (reset-task tile-task (ref yield-forever)))
 
     (GrafOff)

ssc/iigs/bootstub.fnl

@@ -1,8 +1,14 @@
 (import-macros {:sss ! : compile} :ssc.macros)
 
 #(compile $1
-   (start-symbol boot)
+   (start-symbol boot-8)
    (org 0x1000)
+   (fn boot-8 ()
+     (asm (clc) (xce) (rep 0x30)  ; disable emulation mode, 16-bit index registers
+          (jsr boot)
+          (sec) (xce))) ; re-enter emulation mode
+
+   (org 0x060000)
    (require ssc.iigs.toolbox)
    (require ssc.task)
 
@@ -11,8 +17,10 @@
    (global long BootHandle-01)
    (global long BootHandle-e0)
    (global long BootHandle-e1)
+   (global long BootHandle-06)
+
    (fn boot ()
-     (asm (clc) (xce) (rep 0x30)) ; disable emulation mode, 16-bit index registers
+     (asm (phk) (plb)) ; data currently lives in program bank
      (save-dp-sp 0x0800)
      (set-task-base 0x0800) ; space for 8 tasks
      (save-6502-stack)
@@ -25,6 +33,7 @@
      (set! BootUserID (GetNewID 0x1f00))
 
      (LoadOneTool ToolsetMemoryManager 0x0100)
+     (set! BootHandle-06 (NewHandle 0xffff BootUserID 0xb017 0x060000))
      (set! BootHandle-00 (NewHandle 0xb800 BootUserID 0xb017 0x000800))
      (set! BootHandle-01 (NewHandle 0xb800 BootUserID 0xb017 0x010800))
      (set! BootHandle-e0 (NewHandle 0x4000 BootUserID 0xb017 0xe02000))
@@ -36,12 +45,12 @@
      (DisposeHandle BootHandle-e0)
      (DisposeHandle BootHandle-01)
      (DisposeHandle BootHandle-00)
+     (DisposeHandle BootHandle-06)
      (DeleteID BootUserID)
 
      (MTShutDown)
 
      (restore-6502-stack)
      (restore-dp-sp)
-     (asm (sec) (xce)) ; re-enter emulation mode
+     (asm (rtl))))
-   ))
 

ssc/iigs/graphics.fnl

@@ -0,0 +1,48 @@
+; IIgs graphical architecture:
+; PREMISE: All small-scale bitmapped graphics are encoded as code that pushes the graphics onto the stack,
+; which has been aligned to the appropriate place to draw said graphics.
+; Jump tables are stored in the main code segment so that eg. tiles can be easily calculated by index, and
+; so we don't have to explicitly pass longs to a regular function.
+
+(import-macros {:sss ! : compile} :ssc.macros)
+(local lume (require :lib.lume))
+(local {: countiter} (require :lib.util))
+
+#(compile $1
+  (global word draw-object-saved-stack 0)
+  (fn draw-object (screen object)
+    (asm (sei)  ; disable interrupts
+         (lda object) (sta [{:abs #(+ ($1:lookup-addr :draw-object-current-object-jump) 1)}])
+         (tsc) (sta draw-object-saved-stack)
+         (lda screen) (tcs)
+         (lda :0xc068) (ora 0x30) (sta :0xc068) ; set altzp
+      draw-object-current-object-jump
+         (jmp draw-object)
+      draw-object-finished (export draw-object-finished)
+         (lda :0xc068) (and 0xffcf) (sta :0xc068) ; clear altzp
+         (lda draw-object-saved-stack) (tcs)
+         (cli))) ; enable interrupts
+
+  (form drawfn [(fn [ssc name ...]
+    (assert (not (ssc:defining?)) "drawfn must be defined at top level")
+    (set ssc.locals nil) ; locals cannot be used
+    (local asm (ssc:expr-poly (lume.concat [:do ...] [[:asm [:jmp :draw-object-finished]]])))
+    (set ssc.locals [])
+    (ssc:expr-poly [:form name (fn [ssc] (assert (= ssc.locals nil) (.. name " must be called from a drawfn")) [:jmp name])])
+    (ssc:expr-poly [:getter name [:ref name]])
+    (ssc.org:append name asm))])
+
+  (drawfn pei-slam-tile
+    (asm (tdc) (tax) ; store direct page register in X
+         (tsc) (sec) (sbc 255) (tcd)
+         [(lume.concat [:block] (icollect [_ (countiter 16)]
+            [(! block (pei (:d0xfe)) (pei (:d0xfc)) (pei (:d0xfa)) (pei (:d0xf8))
+                      (tsc) (sbc 152) (tcs) (sbc 255) (tcd))]))]
+         (txa) (tcd))) ; restore direct page register
+
+  (drawfn pei-slam-scanline
+    (asm (tdc) (tax) ; store direct page register in X
+         (tsc) (sec) (sbc 255) (tcd)
+         [(lume.concat [:block] (icollect [offset (countiter 0xfe (- 0x100 160) -2)] [:pei [(.. :d offset)]]))]
+         (txa) (tcd))) ; restore direct page register
+)

ssc/init.fnl

@@ -97,7 +97,7 @@
 (fn Ssc.was-dropped [self localcount]
   (set self.locals (lume.slice self.locals 1 (- (length self.locals) localcount))))
 
-(fn Ssc.defining? [self] (> (length self.locals) 0))
+(fn Ssc.defining? [self] (or (= self.locals nil) (> (length self.locals) 0)))
 
 ; 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
@@ -199,10 +199,12 @@
 (fn Ssc.asm-localify [self block]
   (icollect [_ inst (ipairs block)]
     (match inst
-      (where [op loc ?off]      (self:local-offset loc)) [op (+ (self:local-offset loc) (or ?off 0)) :s]
+      (where [op loc ?off] (and (= (type loc) :string) (self:local-offset loc)))
-      (where [op [loc ?off] :y] (self:local-offset loc)) [op [(+ (self:local-offset loc) (or ?off 0)) :s] :y]
+        [op (+ (self:local-offset loc) (or ?off 0)) :s]
-      [:block]                                           (self:asm-localify inst)
+      (where [op [loc ?off] :y]  (and (= (type loc) :string) (self:local-offset loc)))
-      _                                                  inst)))
+        [op [(+ (self:local-offset loc) (or ?off 0)) :s] :y]
+      [:block] (self:asm-localify inst)
+      _        inst)))
 
 (set Ssc.forms
   {:asm (fn [self ...] (if (self:defining?) (self:asm-localify [:block ...]) (self.org:append (table.unpack (self:asm-localify [...])))))
@@ -250,6 +252,7 @@
                cl-false (if ?iffalse [[:bra :-if-done-] :-if-false- c-false :-if-done-]
                                      [:-if-false-])]
            (values (lume.concat block cl-false) etype)))
+   :when (lambda [self test ...] (self:expr-poly [:if test [:do ...]]))
    :while (lambda [self test ...]
             (let [block [:block :-loop-top- (self:gen-condition test :-enter-loop- :-exit-loop-) :-enter-loop-]
                   c-body (self:expr-poly [:do ...])]
@@ -271,7 +274,7 @@
               (if (and (= etype :word) (>= opgen.const -2) (<= opgen.const 2))
                   (match opgen.const -1 [:inc] -2 [:block [:inc] [:inc]]
                                       1 [:dec]  2 [:block [:dec] [:dec]])
-                [:block [:clc] (self:simple-accumulator :adc etype opgen)]))
+                [:block [:sec] (self:simple-accumulator :sbc etype opgen)]))
             first ...)))
     :| (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :ora $...) first ...))
     :& (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :and $...) first ...))
@@ -341,12 +344,13 @@
 (fn Ssc.local-offset [self name-or-index]
   (var offset nil)
   (var stacklen 0)
-  (for [i 1 (length self.locals)]
+  (when self.locals
-    (let [loc (. self.locals i)
+    (for [i 1 (length self.locals)]
-          size (match loc.type :placeholder 0 :word 2 :long 4 _ (error (.. "how big is this local??" (fv loc))))]
+      (let [loc (. self.locals i)
-      (set stacklen (+ stacklen size))
+            size (match loc.type :placeholder 0 :word 2 :long 4 _ (error (.. "how big is this local??" (fv loc))))]
-      (when (or (= i name-or-index) (= loc.name name-or-index))
+        (set stacklen (+ stacklen size))
-        (set offset stacklen))))
+        (when (or (= i name-or-index) (= loc.name name-or-index))
+          (set offset stacklen)))))
   (when offset (+ (- stacklen offset) 1)))
 
 (fn Ssc.local-type [self name-or-index]
@@ -443,7 +447,8 @@
 
 (fn Ssc.expr-poly [self expr]
   (self:enter-expr expr)
-  (let [(success c-expr etype)
+  (let [meta (or self.expr-metadata {:filename "<unknown>" :line "??"})
+        (success c-expr etype)
         (pcall #(match expr
                   (where lit (?. (self:opgen lit) :hi)) (let [{: lo : hi} (self:opgen lit)]
                     (values [:block (lo :lda) [:sta self.LONG_LO] (hi :lda) [:sta self.LONG_HI]] :long))
@@ -458,9 +463,9 @@
                       (values cexpr (or etype :word)))
                   nil (values [:block] :void)
                   _ (error (.. "Unrecognized expression"))))]
-    (if success (values c-expr etype)
+    (if success (do (when (and c-expr (= (getmetatable c-expr) nil)) (setmetatable c-expr meta))
-      (let [{: filename : line} (or self.expr-metadata {:filename "<unknown>" :line "??"})]
+                    (values c-expr etype))
-        (error (.. filename "@" line ": " c-expr "\n" (fv expr)))))))
+      (let [{: filename : line} meta] (error (.. filename "@" line ": " c-expr "\n" (fv expr)))))))
 
 (fn Ssc.expr-word [self expr]
   (let [(c etype) (self:expr-poly expr)]

ssc/task.fnl

@@ -11,8 +11,8 @@
 
   (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]]])
-  (form save-6502-stack    [#[:block [:tsc] [:tay] [:and 0xff] [:ora 0x100] [:tax] [:eor 0xffff] [:clc] [:adc 0x200] [:mvn 0 0]]])
+  (form save-6502-stack    [#[:block [:tsc] [:tay] [:and 0xff] [:ora 0x100] [:tax] [:eor 0xffff] [:clc] [:adc 0x200] [:phb] [:mvn 0 0] [:plb]]])
-  (form restore-6502-stack [#[:block [:tsc] [:tax] [:and 0xff] [:ora 0x100] [:tay] [:eor 0xffff] [:clc] [:adc 0x200] [:mvn 0 0]]])
+  (form restore-6502-stack [#[:block [:tsc] [:tax] [:and 0xff] [:ora 0x100] [:tay] [:eor 0xffff] [:clc] [:adc 0x200] [:phb] [:mvn 0 0] [:plb]]])
 ; 0x1ef = 0x1ef-0x1ff = 0x0f -> 0x7f
   (const task-size 0x100)
   (global word first-task)