32-bit support!! toolbox is currently broken but the main compiler seems to have stabilized

neutgs/init.fnl

@@ -1,20 +1,11 @@
 (local Ssc (require :ssc))
 (import-macros {:sss ! : compile} :ssc.macros)
 
-(local ssc (Ssc))
+(local ssc (Ssc {:boot-org 0xc00}))
-(set ssc.prg.start-symbol :boot)
 (compile ssc
   (require :ssc.iigs.toolbox)
 
-  (org 0xc00)
+  (asm pascalhex (db 5) hexbuf (bytes "     "))
-  (asm
-    boot
-      (clc) (xce) (rep 0x30) ; disable emulation mode, 16-bit index registers
-      (jsr main)
-      (sec) (xce) ;re-enter emulation mode
-      (rts)
-    pascalhex (db 5) hexbuf (bytes "     "))
-
   (fn printnum (num)
     (HexIt num (& hexbuf))
     (WriteString 0 (& pascalhex)))
@@ -32,6 +23,7 @@
       (IMShutDown)
       (MMShutDown userid)
       (TLShutDown)))
+
 )
 
 (ssc:assemble)

ssc/iigs/toolbox.fnl

@@ -13,14 +13,14 @@
                          expected-arg-count (if error-handler (+ expected-arg-count 1) expected-arg-count)
                          block [:block]]
                      (assert (= arg-count expected-arg-count))
-                     (when resultptr (lume.push block (ssc:compile-expr resultptr) (ssc:push)))
+                     (when resultptr (lume.push block (ssc:expr-word resultptr) (ssc:push)))
                      (for [_ 1 return-words] (lume.push block (ssc:push)))
-                     (for [i 1 param-words]  (lume.push block (ssc:compile-expr (select i ...)) (ssc:push)))
+                     (for [i 1 param-words]  (lume.push block (ssc:expr-word (select i ...)) (ssc:push)))
                      (lume.push block [:ldx cmd] [:jsr :0xe10000])
                      (ssc:was-dropped param-words)
                      (when error-handler
                        (lume.push block [:bcc :-no-error-]
-                                        (ssc:push :error) (ssc:compile-expr error-handler) (ssc:drop)
+                                        (ssc:push :error) (ssc:expr-word error-handler) (ssc:drop)
                                         :-no-error-))
                      (if (= return-words 1) (lume.push block (ssc:pop))
 
@@ -31,7 +31,7 @@
                                            (when (< i return-words) (lume.push block [:iny] [:iny]))))
                                        (lume.push block (ssc:drop))))
                      block))]
-      (ssc:compile-expr [:form name call])))])
+      (ssc:expr-poly [:form name call])))])
 
   ; todo: some kind of type system, or wrappers for 32-bit pointers, god
 

ssc/init.fnl

@@ -5,7 +5,8 @@
 ; optimizations are a non-goal; if you want to tune the generated code, go ahead and write
 ; the assembly directly.
 
-; * All values are 16-bit integers, like Forth or BCPL.
+; * Values default to 16-bit integers, like Forth or BCPL.
+; * 32-bit integers are also handled, and the "last value" is stored in a separate "register" in the direct page.
 ; * Data and return addresses are mixed on one stack, unlike Forth.
 ; * Function calls take a fixed number of arguments, and return 0 or 1 results. The compiler enforces arity checking.
 ; * To call a function taking arguments [arg1 arg2 arg3], all 3 arguments should be pushed to the stack before calling.
@@ -36,32 +37,58 @@
 ; * implement loops
 ; * implement "getters" (subroutine that runs when referenced by name without an explicit call)
 
+(import-macros {:sss ! : compile} :ssc.macros)
 (local Object (require :core.object))
 (local lume (require :lib.lume))
 (local Ssc (Object:extend))
 (local Prg (require :asm.asm))
 (local util (require :lib.util))
 
+(set Ssc.LONG_LO :d0x00)
+(set Ssc.LONG_HI :d0x02)
+
 (fn Ssc.new [self ?opts]
   (local opts (or ?opts {}))
   (set self.prg (or opts.prg (Prg.new nil :65816)))
   (set self.forms (lume.clone (or opts.forms self.__index.forms)))
   (set self.functions {})
   (set self.locals [])
-  (set self.modules {}))
+  (set self.modules {})
+  (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 main)
+        (sec) (xce) ;re-enter emulation mode
+        (rts))))))
+
+(fn Ssc.push [self name expr etype]
+  (table.insert self.locals {: name :type etype})
+  (match etype
+    :word [:block expr [:pha]]
+    :long [:block expr [:lda self.LONG_HI] [:pha] [:lda self.LONG_LO] [:pha]]))
+
+(fn Ssc.remove-local [self ?name]
+  (let [loc (. self.locals (length self.locals))]
+    (when (not= loc.name ?name) (error (.. "Internal stack error: expected " (or ?name "temporary") ", got " (or loc.name "temporary"))))
+    (tset self.locals (length self.locals) nil)
+    loc))
+
+(fn Ssc.drop [self ?name]
+  (match (. (self:remove-local ?name) :type)
+    :word [:ply]
+    :long [:block [:ply] [:ply]]))
+
+(fn Ssc.pop [self ?name]
+  (let [{:type etype} (self:remove-local ?name)]
+    (values (match etype
+              :word [:pla]
+              :long [:block [:pla] [:sta self.LONG_LO] [:pla] [:sta self.LONG_HI]])
+            etype)))
 
-(fn Ssc.push [self ?local]
-  (table.insert self.locals (or ?local [:tmp]))
-  [:pha])
-(fn Ssc.drop [self ?local]
-  (match (. self.locals (length self.locals))
-    [:tmp] (when (not= ?local nil) (error (.. "Internal stack error: expected " ?local ", got temporary")))
-    loc    (when (not= ?local loc) (error (.. "Internal stack error: expected " (or ?local "temporary") " temporary, got " loc))))
-  (tset self.locals (length self.locals) nil)
-  [:ply])
-(fn Ssc.pop [self ?local]
-  (self:drop ?local)
-  [:pla])
 (fn Ssc.was-dropped [self localcount]
   (set self.locals (lume.slice self.locals 1 (- (length self.locals) localcount))))
 
@@ -78,11 +105,24 @@
   (fn [_ iprev] (let [i (if iprev (+ iprev 2) 1)]
                           (when (< i (length l)) (values i (. l i) (. l (+ i 1)))))))
 
+; Comparison theory:
+; word x word constant -> word
+; long x long constant -> word
+; word x word -> word
+; long x long -> word
+; Any combination of word and long gets promoted to long (we have to compare both words anyway).
+
+; this should hold for beq and bpl, but not bmi and bne
+; optimized cases:
+; reg + immediate
+; reg + stack? nope, reg + stack isn't really possible when the operator isn't commutative
+; stack + reg
+
 (fn boolop [self left right branch]
-  (let [compiled-left    (self:compile-expr left)
+  (let [compiled-left    (self:expr-word left)
         push-left        (when (not= (type right) :number) (self:push))
         compiled-compare (if (not push-left) [:cmp right]
-                           [:block push-left (self:compile-expr right) [:cmp 1 :s]])
+                           [:block push-left (self:expr-word right) [:cmp 1 :s]])
         drop-left (when push-left (self:drop))]
     [:block
       compiled-left
@@ -95,105 +135,180 @@
     :-finished-
       drop-left]))
 
+; 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)
+; 2. load left into accumulator
+; 3. apply until done
+(fn Ssc.accumulation-op [self op first ...]
+  (var etype (self:type-expr first))
+  (for [i 1 (select :# ...)] (when (= (self:type-expr (select i ...)) :long) (set etype :long)))
+  (let [args (icollect [_ val (ipairs [...])] (self:push-addressible val))
+        setup (icollect [_ {: setup} (ipairs args)] (when setup (setup)))
+        acc (: self (.. :expr- etype) first)
+        operations (icollect [i addr (ipairs args)] (op etype addr i))
+        cleanup (icollect [_ {: cleanup} (ipairs args)] (when cleanup (cleanup)))]
+    (values (lume.concat [:block] setup [acc] operations cleanup) etype)))
+
 (set Ssc.forms
   {:asm (fn [self ...]
           (if (self:defining?) [:block ...]
             (self.org:append ...)))
    :org (lambda [self org] (set self.org (self.prg:org org)))
-   :do (fn [self ...] (lume.concat [:block] (icollect [i (countiter (select :# ...))] (self:compile-expr (select i ...)))))
+   :start-symbol (lambda [self symbol] (set self.prg.start-symbol symbol))
+   :form (lambda [self name func] (tset self.forms name func))
+   :require (lambda [self name]
+              (when (= (. self.modules name) nil)
+                (let [mod (util.reload name)
+                      func (if (= (type mod) :function) mod mod.module)]
+                  (tset self.modules name mod)
+                  (func self))))
+   :do (fn [self ...]
+         (var etype-body :void)
+         (local c-body (lume.concat [:block] (icollect [i (countiter (select :# ...))]
+                                               (let [(expr etype) (self:expr-poly (select i ...))]
+                                                 (set etype-body etype)
+                                                 expr))))
+         (values c-body etype-body))
    :let (fn [self bindings ...]
-          (lume.concat [:block]
+          (let [compiled-bindings    (icollect [_ symbol expr (pairoff bindings)] (self:push symbol (self:expr-poly expr)))
-                       (icollect [_ symbol expr (pairoff bindings)]
+                (compiled-body etype) (self:expr-poly [:do ...])
-                          [:block (self:compile-expr expr) (self:push symbol)])
+                compiled-cleanup     (icollect [i-half (countiter (/ (length bindings) 2))]
-                       [(self:compile-expr [:do ...])]
+                                       (self:drop (. bindings (- (length bindings) (* i-half 2) -1))))]
-                       (icollect [i-half (countiter (/ (length bindings) 2))]
+            (values (lume.concat [:block] compiled-bindings [compiled-body] compiled-cleanup) etype)))
-                          (self:drop (. bindings (- (length bindings) (* i-half 2) -1))))))
+   :fn (lambda [self name args ...]
+         (assert (not (self:defining?)) "Can't nest function definitions")
+         (local arglocals (icollect [_ arg (ipairs args)] (match arg
+                                                           [:long aname] {:name aname :type :long}
+                                                           aname         {:name aname :type :word})))
+         (set self.locals (lume.concat arglocals [{:type :word :comment :returnaddr}]))
+         ; todo: maybe handle mutually recursive functions? (compile-expr only has access to currently-defined functions)
+         (local (c-function etype) (self:expr-poly [:do ...]))
+         (self.org:append name c-function [:rts])
+         (tset self.functions name {:arity (length args) :args arglocals :org self.org :type etype})
+         (assert (= (length self.locals) (+ (length args) 1))
+                 (.. "Left locals on stack?? Expected " (tostring (+ (length args) 1)) " got " (tostring (length self.locals))))
+         (set self.locals []))
+   :if (lambda [self test iftrue ?iffalse]
+         (let [c-test (self:expr-word test)
+               (c-true truetype) (self:expr-poly iftrue)
+               (c-false falsetype) (when ?iffalse (self:expr-poly ?iffalse))
+               etype (if (and falsetype (not= truetype falsetype)) :void truetype)]
+           (values (lume.concat [:block
+                                   c-test
+                                   [:cmp 0] [:beq (if ?iffalse :-elseblock- :-finished-)]
+                                   c-true]
+                                (when ?iffalse [
+                                    [:bra :-finished-]
+                                  :-elseblock- c-false])
+                                [:-finished-]) etype)))
+
    :+ (lambda [self first ...]
-        (local block [:block (self:compile-expr first)])
+        (self:accumulation-op
-        (for [i 1 (select :# ...)]
+          (fn [etype {: lo : hi : const}]
-          (let [val (select i ...)]
+            (match etype
-            (table.insert block
+              :word (if (= const 1)  [:inc] (= const 2)  [:block [:inc] [:inc]]
-              (match val
+                        (= const -1) [:dec] (= const -2) [:block [:dec] [:dec]]
-                 1 [:inc]  2 [:block [:inc] [:inc]]
+                      [:block [:clc] (lo :adc)])
-                -1 [:dec] -2 [:block [:dec] [:dec]]
+              :long [:block [:clc] (lo :lda) [:adc self.LONG_LO] [:sta self.LONG_LO]
-                (where val (= (type val) :number)) [:block [:clc] [:adc val]]
+                                   (if hi (hi :lda) [:lda 0]) [:adc self.LONG_HI] [:sta self.LONG_HI]]))
-                (where sym (= (type sym) :string) (self:local-offset sym)) [:block [:clc] [:adc (self:local-offset sym) :s]]
+          first ...))
-                _ [:block (self:push) (self:compile-expr val) [:clc] [:adc 1 :s] (self:drop)]))))
-        block)
    :- (lambda [self first ...]
-        (let [block [:block (self:compile-expr first)]
+        (self:accumulation-op
-              nargs (select :# ...)]
+          (fn [etype {: lo : hi : const}]
-          (if (= nargs 0) (table.insert block [:block [:eor 0xffff] [:inc]]) ; negate with two's complement
+            (match etype
-            (for [i 1 nargs]
+              :word (if (= const 1)  [:dec] (= const 2)  [:block [:dec] [:dec]]
-              (let [val (select i ...)]
+                        (= const -1) [:inc] (= const -2) [:block [:inc] [:inc]]
-                (table.insert block
+                      [:block [:sec] (lo :sbc)])
-                  (match val
+              :long [:block [:sec] (lo :lda) [:sbc self.LONG_LO] [:sta self.LONG_LO]
-                     1 [:dec]  2 [:block [:dec] [:dec]]
+                                   (if hi (hi :lda) [:lda 0]) [:sbc self.LONG_HI] [:sta self.LONG_HI]]))))
-                    -1 [:inc] -2 [:block [:inc] [:inc]]
-                    (where val (= (type val) :number)) [:block [:sec] [:sbc val]]
-                    (where sym (= (type sym) :string) (self:local-offset sym)) [:block [:sec] [:sbc (self:local-offset sym) :s]]
-                    _ [:block (self:push) (self:compile-expr val) [:sec] [:sbc 1 :s] (self:drop)])))))
-          block))
     := (lambda [self lhs rhs] (boolop self lhs rhs :beq))
     :not= (lambda [self lhs rhs] (boolop self lhs rhs :bne))
     :< (lambda [self lhs rhs] (boolop self lhs rhs :bmi))
     :> (lambda [self lhs rhs] (boolop self rhs lhs :bmi))
     :>= (lambda [self lhs rhs] (boolop self lhs rhs :bpl))
     :<= (lambda [self lhs rhs] (boolop self rhs lhs :bpl))
-    :not (lambda [self bool] (self:compile-expr [:if bool 0 0xffff]))
+    :not (lambda [self bool] (self:expr-poly [:if bool 0 0xffff]))
-    :if (lambda [self test iftrue ?iffalse]
+    :or (lambda [self lhs rhs] (self:expr-poly [:if lhs 0xffff [:if rhs 0xffff 0]]))
-          (lume.concat
+    :and (lambda [self lhs rhs] (self:expr-poly [:if lhs [:if rhs 0xffff 0] 0]))
-            [:block
+    :& (lambda [self label] [:lda #($1:lookup-addr label)])
-              (self:compile-expr test)
-              [:cmp 0]
-              [:beq :-elseblock-]
-              (self:compile-expr iftrue)]
-              (when ?iffalse [[:bra :-finished-]])
-            [:-elseblock-]
-              (when ?iffalse [(self:compile-expr ?iffalse)])
-            [:-finished-]))
-    :fn (lambda [self name args ...]
-          (assert (not (self:defining?)))
-          (set self.locals (lume.concat args [[:tmp]]))
-          (tset self.functions name {:arity (length args) : args :org self.org})
-          ; todo: maybe handle mutually recursive functions? (compile-expr only has access to currently-defined functions)
-          (self.org:append name (self:compile-expr (lume.concat [:do ...] [[:asm [:rts]]])))
-          (assert (= (length self.locals) (+ (length args) 1)))
-          (set self.locals []))
-    :form (lambda [self name func] (tset self.forms name func))
-    :require (lambda [self name]
-               (when (= (. self.modules name) nil)
-                 (let [mod (util.reload name)
-                       func (if (= (type mod) :function) mod mod.module)]
-                   (tset self.modules name mod)
-                   (func self))))
-     :& (lambda [self label] [:lda #($1:lookup-addr label)])
   })
 
-(fn Ssc.local-offset [self symbol]
+(fn Ssc.local-offset [self name-or-index]
   (var offset nil)
   (for [i 1 (length self.locals)]
-    (when (= (. self.locals i) symbol)
+    (when (or (= i name-or-index) (= (. self.locals i :name) name-or-index))
       (set offset (+ 1 (* 2 (- (length self.locals) i))))))
   offset)
 
-(fn Ssc.compile-expr [self expr]
+(fn Ssc.local-type [self name-or-index]
+  (var etype nil)
+  (for [i 1 (length self.locals)]
+    (when (or (= i name-or-index) (= (. self.locals i :name) name-or-index))
+      (set etype (. self.locals i :type))))
+  etype)
+
+(fn Ssc.set-long [self loexpr hiexpr]
+  [:block loexpr [:sta self.LONG_LO] hiexpr [:sta self.LONG_HI]])
+(fn Ssc.set-long-local [self loc]
+  (self:set-long [:lda (self:local-offset loc) :s] [:lda (+ (self:local-offset loc) 2) :s]))
+
+(fn Ssc.type-expr [self expr] (let [(_ etype) (self:expr-poly expr)] etype))
+
+(fn Ssc.addressible-const [self const]
+  {:lo #[$1 (bit.band const 0xffff)] :hi (let [hi (bit.rshift (bit.band 0xffff0000) 16)] (if (or (= hi 0) (= hi 0xffff)) nil #[$1 hi])) : const})
+(fn Ssc.addressible-loc [self loc]
+  {:lo #[$1 (self:local-offset loc) :s] :hi (when (= (self:local-type loc) :long) #[$1 (+ (self:local-offset loc) 2)])})
+
+(fn Ssc.addressible [self expr]
+  (match (type expr)
+    :number                                  (self:addressible-const expr)
+    (where :string (self:local-offset expr)) (self:addressible-loc expr)))
+
+(fn Ssc.push-addressible [self expr]
+  (or (self:addressible expr)
+      (let [c (self:push nil (self:expr-poly expr))
+            iloc (length (self.locals))]
+        (lume.merge (self:addressible-loc iloc) {:setup #c :cleanup #(self:drop)}))))
+
+(fn Ssc.expr-poly [self expr]
   (match expr
-    (where num (= (type num) :number)) [:lda num]
+    (where lit (?. (self:addressible lit) :hi)) (let [{: lo : hi} (self:addressible lit)]
-    (where loc (= (type loc) :string) (self:local-offset loc)) [:lda (self:local-offset loc) :s]
+      (values [:block (lo :lda) [:sta self.LONG_LO] (hi :lda) [:sta self.LONG_HI]] :long))
+    (where lit (?. (self:addressible lit) :lo)) (let [{: lo} (self:addressible lit)] (values (lo :lda) :word))
     ; TODO: Global scope
     (where [func & args] (= (?. self.functions func :arity) (length args)))
-      (let [pre (icollect [_ arg (ipairs args)] [:block (self:compile-expr arg) (self:push)])
+      (let [f (. self.functions func)
+            pre (icollect [iarg arg (ipairs args)]
+                  (let [atype (. f.args iarg :type)
+                        c-arg (: self (.. :expr- atype) arg)
+                        c-push (self:push nil c-arg atype)]
+                    c-push))
             post (icollect [_ (countiter (length args))] (self:drop))]
-        (lume.concat [:block] pre [[:jsr func]] post))
+        (print (fv pre) (fv post) (fv args))
+        (values (lume.concat [:block] pre [[:jsr func]] post) f.type))
     (where [form & args] (. self.forms form))
-      ((. self.forms form) self (table.unpack args))
+      (let [f (. self.forms form)
-    nil [:block]
+            (cexpr etype) (f self (table.unpack args))]
+        (values cexpr (or etype :word)))
+    nil (values [:block] :void)
     _ (error (.. "Unrecognized expression " (fv expr)))))
 
+(fn Ssc.expr-word [self expr]
+  (let [(c etype) (self:expr-poly expr)]
+    (when (not= etype :word) (error "Unexpected long or void in " (fv expr) " - please wrap in explicit truncation form"))
+    c))
+
+(fn Ssc.expr-long [self expr]
+  (let [(c etype) (self:expr-poly expr)]
+    (match etype
+      :long c
+      :word [:block c [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]]
+      _ (error "Unexpected type " etype " in " (fv expr) " - wanted long or word"))))
+
 (fn Ssc.compile [self ...]
   (for [i 1 (select :# ...)]
-    (self:compile-expr (select i ...)))
+    (self:expr-poly (select i ...)))
   self)
 
 (fn Ssc.assemble [self]