From 8eef9e49b8f86fb15f661448e59cd46e7a997117 Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Wed, 11 Aug 2021 22:34:07 -0400 Subject: [PATCH] Fix conditionals! And optimize the hell out of them! --- neutgs/init.fnl | 25 ++++----- ssc/init.fnl | 137 +++++++++++++++++++++++++++++------------------- 2 files changed, 92 insertions(+), 70 deletions(-) diff --git a/neutgs/init.fnl b/neutgs/init.fnl index e35b390..e413fda 100644 --- a/neutgs/init.fnl +++ b/neutgs/init.fnl @@ -20,22 +20,15 @@ (IMStartUp) (TextStartUp) - (let (x 1) - (printnum x) - (set! x (+ x 1)) - (printnum x)) - (set! (long-at (ref hexbuf)) 0x6b636548) - (WriteString (far-ref pascalhex)) - (long! (ref hexbuf) 0x74747542) - (WriteString (far-ref pascalhex)) - (let (buf (ref hexbuf) - str (far-ref pascalhex)) - (long! buf 0x6b726f42) - (WriteString str) - (word! (+ buf 2) 0x706f) - (WriteString str)) - (printnum (hiword (long-at (far-ref pascalhex)))) - +; (if (= 1 1) (printnum 1) (printnum 2)) +; (if (or (< 3 2) (not= 5 10)) (printnum 3) (printnum 4)) + (if (and (or (= 1 2) (< 3 4)) ; + (not (or (> 10 3) (<= 6 5)))) + (printnum 0xdead) (printnum 0xbeef)) + (let (x 5 y 10 test1 (< x y) test2 (> x y)) + (printnum test1) (printnum test2) + (if test1 (printnum 0x1234) (printnum 0x5678)) + (if test2 (printnum 0x1234) (printnum 0x5678))) (TextShutDown) (IMShutDown) (MMShutDown UserID) diff --git a/ssc/init.fnl b/ssc/init.fnl index f91b7c5..560fda6 100644 --- a/ssc/init.fnl +++ b/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) - (c-true truetype) (self:expr-poly iftrue) + (let [(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))) - + 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))) :+ (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)) - :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:expr-poly [:if bool 0 0xffff])) - :or (lambda [self lhs rhs] (self:expr-poly [:if lhs 0xffff [:if rhs 0xffff 0]])) - :and (lambda [self lhs rhs] (self:expr-poly [:if lhs [:if rhs 0xffff 0] 0])) + := (lambda [self lhs rhs] (self:cmp-to-bool := lhs rhs)) + :not= (lambda [self lhs rhs] (self:cmp-to-bool :not= lhs rhs)) + :< (lambda [self lhs rhs] (self:cmp-to-bool :< lhs rhs)) + :> (lambda [self lhs rhs] (self:cmp-to-bool :> lhs rhs)) + :>= (lambda [self lhs rhs] (self:cmp-to-bool :>= lhs rhs)) + :<= (lambda [self lhs rhs] (self:cmp-to-bool :<= lhs rhs)) + :not (lambda [self bool] (self:cmp-to-bool :not bool)) + :or (lambda [self ...] (self:cmp-to-bool :or ...)) + :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)