Fix conditionals! And optimize the hell out of them!

neutgs/init.fnl

@@ -20,22 +20,15 @@
     (IMStartUp)
     (TextStartUp)
 
-    (let (x 1)
+;     (if (= 1 1) (printnum 1) (printnum 2))
-      (printnum x)
+;     (if (or (< 3 2) (not= 5 10)) (printnum 3) (printnum 4))
-      (set! x (+ x 1))
+    (if (and (or (= 1 2) (< 3 4)) ;
-      (printnum x))
+             (not (or (> 10 3) (<= 6 5))))
-    (set! (long-at (ref hexbuf)) 0x6b636548)
+      (printnum 0xdead) (printnum 0xbeef))
-    (WriteString (far-ref pascalhex))
+    (let (x 5 y 10 test1 (< x y) test2 (> x y))
-    (long! (ref hexbuf) 0x74747542)
+      (printnum test1) (printnum test2)
-    (WriteString (far-ref pascalhex))
+      (if test1 (printnum 0x1234) (printnum 0x5678))
-    (let (buf (ref hexbuf)
+      (if test2 (printnum 0x1234) (printnum 0x5678)))
-          str (far-ref pascalhex))
-      (long! buf 0x6b726f42)
-      (WriteString str)
-      (word! (+ buf 2) 0x706f)
-      (WriteString str))
-    (printnum (hiword (long-at (far-ref pascalhex))))
-
     (TextShutDown)
     (IMShutDown)
     (MMShutDown UserID)

ssc/init.fnl

@@ -47,6 +47,8 @@
 
 (set Ssc.LONG_LO :d0x00)
 (set Ssc.LONG_HI :d0x02)
+(set Ssc.TRUE 0xffff)
+(set Ssc.FALSE 0)
 
 (fn Ssc.new [self ?opts]
   (local opts (or ?opts {}))
@@ -109,36 +111,6 @@
   (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:expr-word left)
-        push-left        (when (not= (type right) :number) (self:push))
-        compiled-compare (if (not push-left) [:cmp right]
-                           [:block push-left (self:expr-word right) [:cmp 1 :s]])
-        drop-left (when push-left (self:drop))]
-    [:block
-      compiled-left
-      compiled-compare
-      [branch :-true-]
-      [:lda 0]
-      [:bra :-finished-]
-    :-true-
-      [:lda 0xffff]
-    :-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)
@@ -154,6 +126,70 @@
         cleanup (icollect [_ {: cleanup} (ipairs args)] (when cleanup (cleanup)))]
     (values (lume.concat [:block] setup [acc] operations cleanup) etype)))
 
+; comparisons assume left-hand side was in accumulator and cmp (right-hand side) was just executed.
+; For lobranch, the branch should execute if the comparison is FALSE; the label passed is for the false branch.
+; For hibranch, the branch should not execute if the low word still needs to be compared; otherwise, $1 is the true branch,
+; and $2 is the false branch.
+(set Ssc.comparisons
+  {:<    {:hibranch #[:block [:bcc $1] [:bne $2]] :lobranch #[:bcs $1] :opposite :>=}
+   :>    {:swap :< :opposite :<=}
+   :>=   {:hibranch #[:block [:bcc $2] [:bne $1]] :lobranch #[:bcc $1] :opposite :<}
+   :<=   {:swap :>= :opposite :>}
+   :=    {:hibranch #[:bne $2] :lobranch #[:bne $1] :opposite :not=}
+   :not= {:hibranch #[:bne $1] :lobranch #[:beq $1] :opposite :=}
+ })
+
+(fn Ssc.rewrite-condition [self cond] ; rewrite comparisons down to primitives - <, >=, =, not=, or, and. "or" and "and" can nest.
+  (match cond
+    (where [op] (?. self.comparisons op :hibranch)) ; already a primitive op
+      cond
+    (where [op lhs rhs] (?. self.comparisons op :swap))
+      [(. self.comparisons op :swap) rhs lhs]
+    [:not [:not expr]]
+      (self:rewrite-condition expr)
+    (where [:not [op lhs rhs]] (?. self.comparisons op :opposite))
+      (self:rewrite-condition [(. self.comparisons op :opposite) lhs rhs])
+    (where [:not [op & tests]] (or (= op :or) (= op :and))) ; !(x||y) => (!x)&&(!y)
+      (lume.concat [(if (= op :or) :and :or)] (icollect [_ test (ipairs tests)] (self:rewrite-condition [:not test])))
+    [:not expr]
+      (self:rewrite-condition [:not (self:rewrite-condition expr)])
+    (where [op & tests] (or (= op :or) (= op :and)))
+      (lume.concat [op] (icollect [_ test (ipairs tests)] (self:rewrite-condition test)))
+    _ [:not= cond 0]))
+
+(fn Ssc.gen-condition [self cond truelabel falselabel ?depth ?branch-when-true]
+  (let [depth (or ?depth 0)
+        cond (self:rewrite-condition cond)
+        [op & args] cond
+        cmp (. self.comparisons op)]
+    (pp cond)
+    (if cmp
+        (let [[lhs rhs] args
+              ropgen (self:push-opgen rhs)
+              pre (when ropgen.setup (ropgen.setup))
+              (left etype) (self:expr-poly lhs)
+              truebranch (if ropgen.cleanup (.. :-if-true-cleanup- depth) truelabel)
+              falsebranch (if ropgen.cleanup (.. :-if-false-cleanup- depth) falselabel)
+              hibranch (when (= etype :long)
+                         [[:lda self.LONG_HI] (ropgen.hi :cmp) (cmp.hibranch truebranch falsebranch) [:lda self.LONG_LO]])
+              lobranch [(ropgen.lo :cmp) (cmp.lobranch falsebranch)]
+              cleanup (when ropgen.cleanup (ropgen.cleanup))
+              post (if cleanup [truebranch cleanup [:bra truelabel] falsebranch cleanup [:bra falselabel]]
+                       ?branch-when-true [[:bra truelabel]])]
+          (lume.concat [:block] [pre] [left] hibranch lobranch post))
+
+        (or (= op :or) (= op :and))
+        (lume.concat [:block]
+                     (icollect [itest test (ipairs args)]
+                       (let [lastclause (= itest (length args))
+                             nextlabel (.. :-next- op :-clause- itest :- depth)
+                             whentrue (if (= op :or) truelabel (if lastclause truelabel nextlabel))
+                             whenfalse (if (= op :or) (if lastclause falselabel nextlabel) falselabel)]
+                         [: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]))
+
 (set Ssc.forms
   {:asm (fn [self ...] (if (self:defining?) [:block ...] (self.org:append ...)))
    :asm-long (fn [self ...] (values [:block ...] :long))
@@ -198,19 +234,14 @@
                  (.. "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)
+         (let [(c-true truetype) (self:expr-poly iftrue)
-               (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)]
+               etype (if (not= truetype falsetype) :void truetype)
-           (values (lume.concat [:block
+               block [:block (self:gen-condition test :-if-true- :-if-false-) :-if-true- c-true]
-                                   c-test
+               _ (pp block)
-                                   [:cmp 0] [:beq (if ?iffalse :-elseblock- :-finished-)]
+               cl-false (if ?iffalse [[:bra :-if-done-] :-if-false- c-false :-if-done-]
-                                   c-true]
+                                     [:-if-false-])]
-                                (when ?iffalse [
+           (values (lume.concat block cl-false) etype)))
-                                    [:bra :-finished-]
-                                  :-elseblock- c-false])
-                                [:-finished-]) etype)))
-
    :+ (lambda [self first ...]
         (self:accumulation-op
           (fn [etype {: lo : hi : const}]
@@ -231,15 +262,15 @@
               :long [:block [:sec] (lo :lda) [:sbc self.LONG_LO] [:sta self.LONG_LO]
                                    (if hi (hi :lda) [:lda 0]) [:sbc self.LONG_HI] [:sta self.LONG_HI]]))
           first ...))
-    := (lambda [self lhs rhs] (boolop self lhs rhs :beq))
+    := (lambda [self lhs rhs] (self:cmp-to-bool := lhs rhs))
-    :not= (lambda [self lhs rhs] (boolop self lhs rhs :bne))
+    :not= (lambda [self lhs rhs] (self:cmp-to-bool :not= lhs rhs))
-    :< (lambda [self lhs rhs] (boolop self lhs rhs :bmi))
+    :< (lambda [self lhs rhs] (self:cmp-to-bool :< lhs rhs))
-    :> (lambda [self lhs rhs] (boolop self rhs lhs :bmi))
+    :> (lambda [self lhs rhs] (self:cmp-to-bool :> lhs rhs))
-    :>= (lambda [self lhs rhs] (boolop self lhs rhs :bpl))
+    :>= (lambda [self lhs rhs] (self:cmp-to-bool :>= lhs rhs))
-    :<= (lambda [self lhs rhs] (boolop self rhs lhs :bpl))
+    :<= (lambda [self lhs rhs] (self:cmp-to-bool :<= lhs rhs))
-    :not (lambda [self bool] (self:expr-poly [:if bool 0 0xffff]))
+    :not (lambda [self bool] (self:cmp-to-bool :not bool))
-    :or (lambda [self lhs rhs] (self:expr-poly [:if lhs 0xffff [:if rhs 0xffff 0]]))
+    :or (lambda [self ...] (self:cmp-to-bool :or ...))
-    :and (lambda [self lhs rhs] (self:expr-poly [:if lhs [:if rhs 0xffff 0] 0]))
+    :and (lambda [self ...] (self:cmp-to-bool :and ...))
     :loword (lambda [self long] [:block (self:expr-long long) [:lda self.LONG_LO]])
     :hiword (lambda [self long] [:block (self:expr-long long) [:lda self.LONG_HI]])
     :ref (lambda [self label] [:lda #(loword ($1:lookup-addr label))])
@@ -278,7 +309,6 @@
                                   :word [:block [:lda 0] (hi :sta)]
                                   :long [:block [:lda self.LONG_HI] (hi :sta)]))
                   block [:block]]
-              (pp c-value)
               (lume.push block c-value c-lo c-hi)
               block))
   })
@@ -352,7 +382,7 @@
 (fn Ssc.push-opgen [self expr]
   (or (self:opgen expr)
       (let [c (self:push nil (self:expr-poly expr))
-            iloc (length (self.locals))]
+            iloc (length self.locals)]
         (lume.merge (self:opgen-local iloc) {:setup #c :cleanup #(self:drop)}))))
 
 (fn Ssc.parse-parameters [self params]
@@ -377,7 +407,6 @@
       (let [f (. self.functions func)
             pre (self:push-arguments f.args args)
             post (icollect [_ (countiter (length args))] (self:drop))]
-        (print (fv pre) (fv post) (fv args))
         (values (lume.concat [:block] pre [[:jsr func]] post) f.type))
     (where [form & args] (. self.forms form))
       (let [f (. self.forms form)