Fix conditionals! And optimize the hell out of them!
This commit is contained in:
parent
1eea56bb5b
commit
8eef9e49b8
|
@ -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)
|
||||
|
|
137
ssc/init.fnl
137
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)
|
||||
|
|
Loading…
Reference in a new issue